hls-plugin-api 1.0.0.0 → 1.1.0.0
raw patch · 8 files changed
+1690/−1070 lines, 8 filesdep ~Diffdep ~lspnew-uploaderPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: Diff, lsp
API changes (from Hackage documentation)
- Ide.Plugin.Config: [completionSnippetsOn] :: Config -> !Bool
- Ide.Plugin.Config: [maxNumberOfProblems] :: Config -> !Int
- Ide.Types: WithSnippets :: Bool -> WithSnippets
- Ide.Types: newtype WithSnippets
+ Ide.Plugin.ConfigUtils: pluginsToDefaultConfig :: IdePlugins a -> Value
+ Ide.Plugin.ConfigUtils: pluginsToVSCodeExtensionSchema :: IdePlugins a -> Value
+ Ide.Plugin.Properties: (&) :: a -> (a -> b) -> b
+ Ide.Plugin.Properties: KeyNameProxy :: KeyNameProxy (s :: Symbol)
+ Ide.Plugin.Properties: PropertyKey :: Symbol -> PropertyType -> PropertyKey
+ Ide.Plugin.Properties: TArray :: Type -> PropertyType
+ Ide.Plugin.Properties: TBoolean :: PropertyType
+ Ide.Plugin.Properties: TEnum :: Type -> PropertyType
+ Ide.Plugin.Properties: TInteger :: PropertyType
+ Ide.Plugin.Properties: TNumber :: PropertyType
+ Ide.Plugin.Properties: TObject :: Type -> PropertyType
+ Ide.Plugin.Properties: TString :: PropertyType
+ Ide.Plugin.Properties: [EnumMetaData] :: IsTEnum t ~ 'True => {defaultValue :: ToHsType t, description :: Text, enumValues :: [ToHsType t], enumDescriptions :: [Text]} -> MetaData t
+ Ide.Plugin.Properties: [MetaData] :: IsTEnum t ~ 'False => {defaultValue :: ToHsType t, description :: Text} -> MetaData t
+ Ide.Plugin.Properties: [SArray] :: (ToJSON a, FromJSON a) => Proxy a -> SPropertyKey ('PropertyKey s ('TArray a))
+ Ide.Plugin.Properties: [SBoolean] :: SPropertyKey ('PropertyKey s 'TBoolean)
+ Ide.Plugin.Properties: [SEnum] :: (ToJSON a, FromJSON a, Eq a, Show a) => Proxy a -> SPropertyKey ('PropertyKey s ('TEnum a))
+ Ide.Plugin.Properties: [SInteger] :: SPropertyKey ('PropertyKey s 'TInteger)
+ Ide.Plugin.Properties: [SNumber] :: SPropertyKey ('PropertyKey s 'TNumber)
+ Ide.Plugin.Properties: [SObject] :: (ToJSON a, FromJSON a) => Proxy a -> SPropertyKey ('PropertyKey s ('TObject a))
+ Ide.Plugin.Properties: [SString] :: SPropertyKey ('PropertyKey s 'TString)
+ Ide.Plugin.Properties: data KeyNameProxy (s :: Symbol)
+ Ide.Plugin.Properties: data MetaData (t :: PropertyType)
+ Ide.Plugin.Properties: data Properties (r :: [PropertyKey])
+ Ide.Plugin.Properties: data PropertyKey
+ Ide.Plugin.Properties: data PropertyType
+ Ide.Plugin.Properties: data SPropertyKey (k :: PropertyKey)
+ Ide.Plugin.Properties: defineArrayProperty :: (KnownSymbol s, NotElem s r, ToJSON a, FromJSON a) => KeyNameProxy s -> Text -> [a] -> Properties r -> Properties ('PropertyKey s ('TArray a) : r)
+ Ide.Plugin.Properties: defineBooleanProperty :: (KnownSymbol s, NotElem s r) => KeyNameProxy s -> Text -> Bool -> Properties r -> Properties ('PropertyKey s 'TBoolean : r)
+ Ide.Plugin.Properties: defineEnumProperty :: (KnownSymbol s, NotElem s r, ToJSON a, FromJSON a, Eq a, Show a) => KeyNameProxy s -> Text -> [(a, Text)] -> a -> Properties r -> Properties ('PropertyKey s ('TEnum a) : r)
+ Ide.Plugin.Properties: defineIntegerProperty :: (KnownSymbol s, NotElem s r) => KeyNameProxy s -> Text -> Int -> Properties r -> Properties ('PropertyKey s 'TInteger : r)
+ Ide.Plugin.Properties: defineNumberProperty :: (KnownSymbol s, NotElem s r) => KeyNameProxy s -> Text -> Double -> Properties r -> Properties ('PropertyKey s 'TNumber : r)
+ Ide.Plugin.Properties: defineObjectProperty :: (KnownSymbol s, NotElem s r, ToJSON a, FromJSON a) => KeyNameProxy s -> Text -> a -> Properties r -> Properties ('PropertyKey s ('TObject a) : r)
+ Ide.Plugin.Properties: defineStringProperty :: (KnownSymbol s, NotElem s r) => KeyNameProxy s -> Text -> Text -> Properties r -> Properties ('PropertyKey s 'TString : r)
+ Ide.Plugin.Properties: emptyProperties :: Properties '[]
+ Ide.Plugin.Properties: infixl 1 &
+ Ide.Plugin.Properties: instance (GHC.TypeLits.KnownSymbol s', s GHC.Types.~ s') => GHC.OverloadedLabels.IsLabel s (Ide.Plugin.Properties.KeyNameProxy s')
+ Ide.Plugin.Properties: toDefaultJSON :: Properties r -> [Pair]
+ Ide.Plugin.Properties: toVSCodeExtensionSchema :: Text -> Properties r -> [Pair]
+ Ide.Plugin.Properties: type HasProperty s k t r = (k ~ 'PropertyKey s t, Elem s r, FindByKeyName s r ~ t, KnownSymbol s)
+ Ide.Plugin.Properties: type family ToHsType (t :: PropertyType)
+ Ide.Plugin.Properties: useProperty :: HasProperty s k t r => KeyNameProxy s -> Properties r -> Object -> ToHsType t
+ Ide.Plugin.Properties: usePropertyEither :: HasProperty s k t r => KeyNameProxy s -> Properties r -> Object -> Either String (ToHsType t)
+ Ide.PluginUtils: usePropertyLsp :: (HasProperty s k t r, MonadLsp Config m) => KeyNameProxy s -> PluginId -> Properties r -> m (ToHsType t)
+ Ide.Types: CustomConfig :: Properties r -> CustomConfig
+ Ide.Types: IdeNotification :: SMethod m -> IdeNotification (m :: Method FromClient Notification)
+ Ide.Types: PluginNotificationHandler :: (PluginId -> a -> MessageParams m -> LspM Config ()) -> PluginNotificationHandler a (m :: Method FromClient Notification)
+ Ide.Types: PluginNotificationHandlers :: DMap IdeNotification (PluginNotificationHandler a) -> PluginNotificationHandlers a
+ Ide.Types: [pluginCustomConfig] :: PluginDescriptor ideState -> CustomConfig
+ Ide.Types: [pluginNotificationHandlers] :: PluginDescriptor ideState -> PluginNotificationHandlers ideState
+ Ide.Types: data CustomConfig
+ Ide.Types: data IdeNotification (m :: Method FromClient Notification)
+ Ide.Types: emptyCustomConfig :: CustomConfig
+ Ide.Types: instance Data.GADT.Internal.GCompare Ide.Types.IdeNotification
+ Ide.Types: instance Data.GADT.Internal.GEq Ide.Types.IdeNotification
+ Ide.Types: instance GHC.Base.Monoid (Ide.Types.PluginNotificationHandlers a)
+ Ide.Types: instance GHC.Base.Semigroup (Ide.Types.PluginNotificationHandlers a)
+ Ide.Types: mkCustomConfig :: Properties r -> CustomConfig
+ Ide.Types: mkPluginNotificationHandler :: HasTracing (MessageParams m) => SClientMethod (m :: Method FromClient Notification) -> PluginNotificationMethodHandler ideState m -> PluginNotificationHandlers ideState
+ Ide.Types: newtype PluginNotificationHandler a (m :: Method FromClient Notification)
+ Ide.Types: newtype PluginNotificationHandlers a
+ Ide.Types: type PluginNotificationMethodHandler a m = a -> PluginId -> MessageParams m -> LspM Config ()
- Ide.Plugin.Config: Config :: CheckParents -> !Bool -> !Bool -> !Bool -> !Int -> !Int -> !Bool -> !Bool -> !Bool -> !Text -> !Int -> !Map Text PluginConfig -> Config
+ Ide.Plugin.Config: Config :: CheckParents -> !Bool -> !Bool -> !Bool -> !Int -> !Bool -> !Bool -> !Text -> !Int -> !Map Text PluginConfig -> Config
- Ide.PluginUtils: getClientConfig :: MonadLsp Config m => m (Maybe Config)
+ Ide.PluginUtils: getClientConfig :: MonadLsp Config m => m Config
- Ide.PluginUtils: getPluginConfig :: MonadLsp Config m => PluginId -> m (Maybe PluginConfig)
+ Ide.PluginUtils: getPluginConfig :: MonadLsp Config m => PluginId -> m PluginConfig
- Ide.Types: IdePlugins :: Map PluginId (PluginDescriptor ideState) -> IdePlugins ideState
+ Ide.Types: IdePlugins :: [(PluginId, PluginDescriptor ideState)] -> IdePlugins ideState
- Ide.Types: PluginDescriptor :: !PluginId -> !Rules () -> ![PluginCommand ideState] -> PluginHandlers ideState -> PluginDescriptor ideState
+ Ide.Types: PluginDescriptor :: !PluginId -> !Rules () -> ![PluginCommand ideState] -> PluginHandlers ideState -> CustomConfig -> PluginNotificationHandlers ideState -> PluginDescriptor ideState
- Ide.Types: [ipMap] :: IdePlugins ideState -> Map PluginId (PluginDescriptor ideState)
+ Ide.Types: [ipMap] :: IdePlugins ideState -> [(PluginId, PluginDescriptor ideState)]
Files
- LICENSE +201/−201
- hls-plugin-api.cabal +74/−67
- src/Ide/Logger.hs +29/−29
- src/Ide/Plugin/Config.hs +174/−182
- src/Ide/Plugin/ConfigUtils.hs +126/−0
- src/Ide/Plugin/Properties.hs +430/−0
- src/Ide/PluginUtils.hs +232/−213
- src/Ide/Types.hs +424/−378
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,74 @@-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 +cabal-version: 2.4+name: hls-plugin-api+version: 1.1.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#readme+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.Plugin.ConfigUtils+ Ide.Plugin.Properties+ Ide.PluginUtils+ Ide.Types++ hs-source-dirs: src+ build-depends:+ , aeson+ , base >=4.12 && <5+ , containers+ , data-default+ , dependent-map+ , dependent-sum+ , Diff ^>=0.4.0+ , dlist+ , hashable+ , hslogger+ , lens+ , lsp ^>=1.2+ , opentelemetry+ , process+ , regex-tdfa >=1.3.1.0+ , shake >=0.17.5+ , text+ , unordered-containers++ 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,182 +1,174 @@-{-# 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 - --- --------------------------------------------------------------------- +{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}+module Ide.Plugin.Config+ ( getConfigFromNotification+ , Config(..)+ , parseConfig+ , PluginConfig(..)+ , CheckParents(..)+ ) where++import Control.Applicative+import Data.Aeson hiding (Error)+import qualified Data.Aeson as A+import qualified Data.Aeson.Types as A+import Data.Default+import qualified Data.Map as Map+import qualified Data.Text as T+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+ , diagnosticsDebounceDuration :: !Int+ , liquidOn :: !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+ , diagnosticsDebounceDuration = 350000+ , liquidOn = False+ , 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 .:? "diagnosticsDebounceDuration" .!= diagnosticsDebounceDuration defValue+ <*> o .:? "liquidOn" .!= liquidOn 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+ , "diagnosticsDebounceDuration" .= diagnosticsDebounceDuration+ , "liquidOn" .= liquidOn+ , "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/Plugin/ConfigUtils.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ViewPatterns #-}++module Ide.Plugin.ConfigUtils where++import qualified Data.Aeson as A+import qualified Data.Aeson.Types as A+import Data.Default (def)+import qualified Data.Dependent.Map as DMap+import qualified Data.Dependent.Sum as DSum+import qualified Data.HashMap.Lazy as HMap+import Ide.Plugin.Config+import Ide.Plugin.Properties (toDefaultJSON, toVSCodeExtensionSchema)+import Ide.Types+import Language.LSP.Types++-- Attention:+-- 'diagnosticsOn' will never be added into the default config or the schema,+-- since diagnostics emit in arbitrary shake rules -- we don't know+-- whether a plugin is capable of producing diagnostics.++-- | Generates a defalut 'Config', but remains only effective items+pluginsToDefaultConfig :: IdePlugins a -> A.Value+pluginsToDefaultConfig IdePlugins {..} =+ A.Object $+ HMap.adjust+ ( \(unsafeValueToObject -> o) ->+ A.Object $ HMap.insert "plugin" elems o -- inplace the "plugin" section with our 'elems', leaving others unchanged+ )+ "haskell"+ (unsafeValueToObject (A.toJSON defaultConfig))+ where+ defaultConfig@Config {} = def+ unsafeValueToObject (A.Object o) = o+ unsafeValueToObject _ = error "impossible"+ elems = A.object $ mconcat $ singlePlugin <$> map snd ipMap+ -- Splice genericDefaultConfig and dedicatedDefaultConfig+ -- Example:+ --+ -- {+ -- "plugin-id": {+ -- "globalOn": true,+ -- "codeActionsOn": true,+ -- "codeLensOn": true,+ -- "config": {+ -- "property1": "foo"+ -- }+ -- }+ -- }+ singlePlugin PluginDescriptor {..} =+ let x = genericDefaultConfig <> dedicatedDefaultConfig+ in [pId A..= A.object x | not $ null x]+ where+ (PluginHandlers (DMap.toList -> handlers)) = pluginHandlers+ customConfigToDedicatedDefaultConfig (CustomConfig p) = toDefaultJSON p+ -- Example:+ --+ -- {+ -- "globalOn": true,+ -- "codeActionsOn": true,+ -- "codeLensOn": true+ -- }+ --+ -- we don't generate the config section if the plugin doesn't register any of the following six methods,+ -- which avoids producing trivial configuration for formatters:+ --+ -- "stylish-haskell": {+ -- "globalOn": true+ -- }+ genericDefaultConfig =+ let x = mconcat (handlersToGenericDefaultConfig <$> handlers)+ in ["globalOn" A..= True | not $ null x] <> x+ -- Example:+ --+ -- {+ -- "config": {+ -- "property1": "foo"+ -- }+ --}+ dedicatedDefaultConfig =+ let x = customConfigToDedicatedDefaultConfig pluginCustomConfig+ in ["config" A..= A.object x | not $ null x]++ (PluginId pId) = pluginId++ -- This function captures ide methods registered by the plugin, and then converts it to kv pairs+ handlersToGenericDefaultConfig :: DSum.DSum IdeMethod f -> [A.Pair]+ handlersToGenericDefaultConfig (IdeMethod m DSum.:=> _) = case m of+ STextDocumentCodeAction -> ["codeActionsOn" A..= True]+ STextDocumentCodeLens -> ["codeLensOn" A..= True]+ STextDocumentRename -> ["renameOn" A..= True]+ STextDocumentHover -> ["hoverOn" A..= True]+ STextDocumentDocumentSymbol -> ["symbolsOn" A..= True]+ STextDocumentCompletion -> ["completionOn" A..= True]+ _ -> []++-- | Generates json schema used in haskell vscode extension+-- Similar to 'pluginsToDefaultConfig' but simpler, since schema has a flatten structure+pluginsToVSCodeExtensionSchema :: IdePlugins a -> A.Value+pluginsToVSCodeExtensionSchema IdePlugins {..} = A.object $ mconcat $ singlePlugin <$> map snd ipMap+ where+ singlePlugin PluginDescriptor {..} = genericSchema <> dedicatedSchema+ where+ (PluginHandlers (DMap.toList -> handlers)) = pluginHandlers+ customConfigToDedicatedSchema (CustomConfig p) = toVSCodeExtensionSchema (withIdPrefix "config.") p+ (PluginId pId) = pluginId+ genericSchema = withIdPrefix "globalOn" A..= schemaEntry "plugin" : mconcat (handlersToGenericSchema <$> handlers)+ dedicatedSchema = customConfigToDedicatedSchema pluginCustomConfig+ handlersToGenericSchema (IdeMethod m DSum.:=> _) = case m of+ STextDocumentCodeAction -> [withIdPrefix "codeActionsOn" A..= schemaEntry "code actions"]+ STextDocumentCodeLens -> [withIdPrefix "codeLensOn" A..= schemaEntry "code lenses"]+ STextDocumentRename -> [withIdPrefix "renameOn" A..= schemaEntry "rename"]+ STextDocumentHover -> [withIdPrefix "hoverOn" A..= schemaEntry "hover"]+ STextDocumentDocumentSymbol -> [withIdPrefix "symbolsOn" A..= schemaEntry "symbols"]+ STextDocumentCompletion -> [withIdPrefix "completionOn" A..= schemaEntry "completions"]+ _ -> []+ schemaEntry desc =+ A.object+ [ "scope" A..= A.String "resource",+ "type" A..= A.String "boolean",+ "default" A..= True,+ "description" A..= A.String ("Enables " <> pId <> " " <> desc)+ ]+ withIdPrefix x = "haskell.plugin." <> pId <> "." <> x
+ src/Ide/Plugin/Properties.hs view
@@ -0,0 +1,430 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}+-- See Note [Constraints]+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++module Ide.Plugin.Properties+ ( PropertyType (..),+ ToHsType,+ MetaData (..),+ PropertyKey (..),+ SPropertyKey (..),+ KeyNameProxy (..),+ Properties,+ HasProperty,+ emptyProperties,+ defineNumberProperty,+ defineIntegerProperty,+ defineStringProperty,+ defineBooleanProperty,+ defineObjectProperty,+ defineArrayProperty,+ defineEnumProperty,+ toDefaultJSON,+ toVSCodeExtensionSchema,+ usePropertyEither,+ useProperty,+ (&),+ )+where++import qualified Data.Aeson as A+import qualified Data.Aeson.Types as A+import Data.Either (fromRight)+import Data.Function ((&))+import Data.Kind (Constraint, Type)+import qualified Data.Map.Strict as Map+import Data.Proxy (Proxy (..))+import qualified Data.Text as T+import GHC.OverloadedLabels (IsLabel (..))+import GHC.TypeLits+import Unsafe.Coerce (unsafeCoerce)++-- | Types properties may have+data PropertyType+ = TNumber+ | TInteger+ | TString+ | TBoolean+ | TObject Type+ | TArray Type+ | TEnum Type++type family ToHsType (t :: PropertyType) where+ ToHsType 'TNumber = Double -- in js, there are no distinct types for integers and floating-point values+ ToHsType 'TInteger = Int -- so here we use Double for Number, Int for Integer+ ToHsType 'TString = T.Text+ ToHsType 'TBoolean = Bool+ ToHsType ('TObject a) = a+ ToHsType ('TArray a) = [a]+ ToHsType ('TEnum a) = a++-- ---------------------------------------------------------------------++-- | Metadata of a property+data MetaData (t :: PropertyType) where+ MetaData ::+ (IsTEnum t ~ 'False) =>+ { defaultValue :: ToHsType t,+ description :: T.Text+ } ->+ MetaData t+ EnumMetaData ::+ (IsTEnum t ~ 'True) =>+ { defaultValue :: ToHsType t,+ description :: T.Text,+ enumValues :: [ToHsType t],+ enumDescriptions :: [T.Text]+ } ->+ MetaData t++-- | Used at type level for name-type mapping in 'Properties'+data PropertyKey = PropertyKey Symbol PropertyType++-- | Singleton type of 'PropertyKey'+data SPropertyKey (k :: PropertyKey) where+ SNumber :: SPropertyKey ('PropertyKey s 'TNumber)+ SInteger :: SPropertyKey ('PropertyKey s 'TInteger)+ SString :: SPropertyKey ('PropertyKey s 'TString)+ SBoolean :: SPropertyKey ('PropertyKey s 'TBoolean)+ SObject :: (A.ToJSON a, A.FromJSON a) => Proxy a -> SPropertyKey ('PropertyKey s ('TObject a))+ SArray :: (A.ToJSON a, A.FromJSON a) => Proxy a -> SPropertyKey ('PropertyKey s ('TArray a))+ SEnum :: (A.ToJSON a, A.FromJSON a, Eq a, Show a) => Proxy a -> SPropertyKey ('PropertyKey s ('TEnum a))++-- | Existential wrapper of 'SPropertyKey', with an extra 'MetaData'+data SomePropertyKeyWithMetaData+ = forall k s t.+ (k ~ 'PropertyKey s t) =>+ SomePropertyKeyWithMetaData (SPropertyKey k) (MetaData t)++-- | 'Properties' is a partial implementation of json schema, without supporting union types and validation.+-- In hls, it defines a set of properties which used in dedicated configuration of a plugin.+-- A property is an immediate child of the json object in each plugin's "config" section.+-- It was designed to be compatible with vscode's settings UI.+-- Use 'emptyProperties' and 'useProperty' to create and consume 'Properties'.+newtype Properties (r :: [PropertyKey]) = Properties (Map.Map String SomePropertyKeyWithMetaData)++-- | A proxy type in order to allow overloaded labels as properties' names at the call site+data KeyNameProxy (s :: Symbol) = KnownSymbol s => KeyNameProxy++instance (KnownSymbol s', s ~ s') => IsLabel s (KeyNameProxy s') where+ fromLabel = KeyNameProxy++-- ---------------------------------------------------------------------++type family IsTEnum (t :: PropertyType) :: Bool where+ IsTEnum ('TEnum _) = 'True+ IsTEnum _ = 'False++type family FindByKeyName (s :: Symbol) (r :: [PropertyKey]) :: PropertyType where+ FindByKeyName s ('PropertyKey s t ': _) = t+ FindByKeyName s (_ ': xs) = FindByKeyName s xs++type family Elem (s :: Symbol) (r :: [PropertyKey]) :: Constraint where+ Elem s ('PropertyKey s _ ': _) = ()+ Elem s (_ ': xs) = Elem s xs+ Elem s '[] = TypeError ('Text "The key ‘" ':<>: 'Text s ':<>: 'Text "’ is missing")++type family NotElem (s :: Symbol) (r :: [PropertyKey]) :: Constraint where+ NotElem s ('PropertyKey s _ ': _) = TypeError ('Text "The key ‘" ':<>: 'Text s ':<>: 'Text "’ is already defined")+ NotElem s (_ ': xs) = NotElem s xs+ NotElem s '[] = ()++-- | In row @r@, there is a 'PropertyKey' @k@, which has name @s@ and carries haskell type @t@+type HasProperty s k t r = (k ~ 'PropertyKey s t, Elem s r, FindByKeyName s r ~ t, KnownSymbol s)++-- ---------------------------------------------------------------------++-- | Creates a 'Properties' that defines no property+--+-- Useful to start a definitions chain, for example:+-- @+-- properties =+-- emptyProperties+-- & defineStringProperty+-- #exampleString+-- "Description of exampleString"+-- "Foo"+-- & defineNumberProperty+-- #exampleNumber+-- "Description of exampleNumber"+-- 233+-- @+emptyProperties :: Properties '[]+emptyProperties = Properties Map.empty++insert ::+ (k ~ 'PropertyKey s t, NotElem s r, KnownSymbol s) =>+ KeyNameProxy s ->+ SPropertyKey k ->+ MetaData t ->+ Properties r ->+ Properties (k ': r)+insert kn key metadata (Properties old) =+ Properties+ ( Map.insert+ (symbolVal kn)+ (SomePropertyKeyWithMetaData key metadata)+ old+ )++find ::+ (HasProperty s k t r) =>+ KeyNameProxy s ->+ Properties r ->+ (SPropertyKey k, MetaData t)+find kn (Properties p) = case p Map.! symbolVal kn of+ (SomePropertyKeyWithMetaData sing metadata) ->+ -- Note [Constraints]+ -- It's safe to use unsafeCoerce here:+ -- Since each property name is unique that the redefinition will be prevented by predication on the type level list,+ -- the value we get from the name-indexed map must be exactly the singleton and metadata corresponding to the type.+ -- We drop this information at type level: some of the above type families return '() :: Constraint',+ -- so GHC will consider them as redundant.+ -- But we encode it using semantically identical 'Map' at term level,+ -- which avoids inducting on the list by defining a new type class.+ unsafeCoerce (sing, metadata)++-- ---------------------------------------------------------------------++-- | Given the name of a defined property, generates a JSON parser of 'plcConfig'+usePropertyEither ::+ (HasProperty s k t r) =>+ KeyNameProxy s ->+ Properties r ->+ A.Object ->+ Either String (ToHsType t)+usePropertyEither kn p = parseProperty kn (find kn p)++-- | Like 'usePropertyEither' but returns 'defaultValue' on parse error+useProperty ::+ (HasProperty s k t r) =>+ KeyNameProxy s ->+ Properties r ->+ A.Object ->+ ToHsType t+useProperty kn p = fromRight (defaultValue metadata) . usePropertyEither kn p+ where+ (_, metadata) = find kn p++parseProperty ::+ (k ~ 'PropertyKey s t, KnownSymbol s) =>+ KeyNameProxy s ->+ (SPropertyKey k, MetaData t) ->+ A.Object ->+ Either String (ToHsType t)+parseProperty kn k x = case k of+ (SNumber, _) -> parseEither+ (SInteger, _) -> parseEither+ (SString, _) -> parseEither+ (SBoolean, _) -> parseEither+ (SObject _, _) -> parseEither+ (SArray _, _) -> parseEither+ (SEnum _, EnumMetaData {..}) ->+ A.parseEither+ ( \o -> do+ txt <- o A..: keyName+ if txt `elem` enumValues+ then pure txt+ else+ fail $+ "invalid enum member: "+ <> show txt+ <> ". Expected one of "+ <> show enumValues+ )+ x+ where+ keyName = T.pack $ symbolVal kn+ parseEither :: forall a. A.FromJSON a => Either String a+ parseEither = A.parseEither (A..: keyName) x++-- ---------------------------------------------------------------------++-- | Defines a number property+defineNumberProperty ::+ (KnownSymbol s, NotElem s r) =>+ KeyNameProxy s ->+ -- | description+ T.Text ->+ -- | default value+ Double ->+ Properties r ->+ Properties ('PropertyKey s 'TNumber : r)+defineNumberProperty kn description defaultValue =+ insert kn SNumber MetaData {..}++-- | Defines an integer property+defineIntegerProperty ::+ (KnownSymbol s, NotElem s r) =>+ KeyNameProxy s ->+ -- | description+ T.Text ->+ -- | default value+ Int ->+ Properties r ->+ Properties ('PropertyKey s 'TInteger : r)+defineIntegerProperty kn description defaultValue =+ insert kn SInteger MetaData {..}++-- | Defines a string property+defineStringProperty ::+ (KnownSymbol s, NotElem s r) =>+ KeyNameProxy s ->+ -- | description+ T.Text ->+ -- | default value+ T.Text ->+ Properties r ->+ Properties ('PropertyKey s 'TString : r)+defineStringProperty kn description defaultValue =+ insert kn SString MetaData {..}++-- | Defines a boolean property+defineBooleanProperty ::+ (KnownSymbol s, NotElem s r) =>+ KeyNameProxy s ->+ -- | description+ T.Text ->+ -- | default value+ Bool ->+ Properties r ->+ Properties ('PropertyKey s 'TBoolean : r)+defineBooleanProperty kn description defaultValue =+ insert kn SBoolean MetaData {..}++-- | Defines an object property+defineObjectProperty ::+ (KnownSymbol s, NotElem s r, A.ToJSON a, A.FromJSON a) =>+ KeyNameProxy s ->+ -- | description+ T.Text ->+ -- | default value+ a ->+ Properties r ->+ Properties ('PropertyKey s ('TObject a) : r)+defineObjectProperty kn description defaultValue =+ insert kn (SObject Proxy) MetaData {..}++-- | Defines an array property+defineArrayProperty ::+ (KnownSymbol s, NotElem s r, A.ToJSON a, A.FromJSON a) =>+ KeyNameProxy s ->+ -- | description+ T.Text ->+ -- | default value+ [a] ->+ Properties r ->+ Properties ('PropertyKey s ('TArray a) : r)+defineArrayProperty kn description defaultValue =+ insert kn (SArray Proxy) MetaData {..}++-- | Defines an enum property+defineEnumProperty ::+ (KnownSymbol s, NotElem s r, A.ToJSON a, A.FromJSON a, Eq a, Show a) =>+ KeyNameProxy s ->+ -- | description+ T.Text ->+ -- | valid enum members with each of description+ [(a, T.Text)] ->+ a ->+ Properties r ->+ Properties ('PropertyKey s ('TEnum a) : r)+defineEnumProperty kn description enums defaultValue =+ insert kn (SEnum Proxy) $ EnumMetaData defaultValue description (fst <$> enums) (snd <$> enums)++-- ---------------------------------------------------------------------++-- | Converts a properties definition into kv pairs with default values from 'MetaData'+toDefaultJSON :: Properties r -> [A.Pair]+toDefaultJSON (Properties p) = [toEntry s v | (s, v) <- Map.toList p]+ where+ toEntry :: String -> SomePropertyKeyWithMetaData -> A.Pair+ toEntry (T.pack -> s) = \case+ (SomePropertyKeyWithMetaData SNumber MetaData {..}) ->+ s A..= defaultValue+ (SomePropertyKeyWithMetaData SInteger MetaData {..}) ->+ s A..= defaultValue+ (SomePropertyKeyWithMetaData SString MetaData {..}) ->+ s A..= defaultValue+ (SomePropertyKeyWithMetaData SBoolean MetaData {..}) ->+ s A..= defaultValue+ (SomePropertyKeyWithMetaData (SObject _) MetaData {..}) ->+ s A..= defaultValue+ (SomePropertyKeyWithMetaData (SArray _) MetaData {..}) ->+ s A..= defaultValue+ (SomePropertyKeyWithMetaData (SEnum _) EnumMetaData {..}) ->+ s A..= defaultValue++-- | Converts a properties definition into kv pairs as vscode schema+toVSCodeExtensionSchema :: T.Text -> Properties r -> [A.Pair]+toVSCodeExtensionSchema prefix (Properties p) =+ [(prefix <> T.pack k) A..= toEntry v | (k, v) <- Map.toList p]+ where+ toEntry :: SomePropertyKeyWithMetaData -> A.Value+ toEntry = \case+ (SomePropertyKeyWithMetaData SNumber MetaData {..}) ->+ A.object+ [ "type" A..= A.String "number",+ "markdownDescription" A..= description,+ "default" A..= defaultValue,+ "scope" A..= A.String "resource"+ ]+ (SomePropertyKeyWithMetaData SInteger MetaData {..}) ->+ A.object+ [ "type" A..= A.String "integer",+ "markdownDescription" A..= description,+ "default" A..= defaultValue,+ "scope" A..= A.String "resource"+ ]+ (SomePropertyKeyWithMetaData SString MetaData {..}) ->+ A.object+ [ "type" A..= A.String "string",+ "markdownDescription" A..= description,+ "default" A..= defaultValue,+ "scope" A..= A.String "resource"+ ]+ (SomePropertyKeyWithMetaData SBoolean MetaData {..}) ->+ A.object+ [ "type" A..= A.String "boolean",+ "markdownDescription" A..= description,+ "default" A..= defaultValue,+ "scope" A..= A.String "resource"+ ]+ (SomePropertyKeyWithMetaData (SObject _) MetaData {..}) ->+ A.object+ [ "type" A..= A.String "object",+ "markdownDescription" A..= description,+ "default" A..= defaultValue,+ "scope" A..= A.String "resource"+ ]+ (SomePropertyKeyWithMetaData (SArray _) MetaData {..}) ->+ A.object+ [ "type" A..= A.String "array",+ "markdownDescription" A..= description,+ "default" A..= defaultValue,+ "scope" A..= A.String "resource"+ ]+ (SomePropertyKeyWithMetaData (SEnum _) EnumMetaData {..}) ->+ A.object+ [ "type" A..= A.String "string",+ "description" A..= description,+ "enum" A..= enumValues,+ "enumDescriptions" A..= enumDescriptions,+ "default" A..= defaultValue,+ "scope" A..= A.String "resource"+ ]
src/Ide/PluginUtils.hs view
@@ -1,213 +1,232 @@-{-# 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 - +{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}+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,+ usePropertyLsp)+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 Data.Containers.ListUtils (nubOrdOn)+import Ide.Plugin.Config+import Ide.Plugin.Properties+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) Nothing+ else WorkspaceEdit (Just h) Nothing 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)) $ fmap InL 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 (\p -> (pluginId p, p)) $ nubOrdOn pluginId 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 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 PluginConfig+getPluginConfig plugin = do+ config <- getClientConfig+ return $ flip configForPlugin plugin config++-- ---------------------------------------------------------------------++-- | Returns the value of a property defined by the current plugin.+usePropertyLsp ::+ (HasProperty s k t r, MonadLsp Config m) =>+ KeyNameProxy s ->+ PluginId ->+ Properties r ->+ m (ToHsType t)+usePropertyLsp kn pId p = do+ config <- getPluginConfig pId+ return $ useProperty kn p $ plcConfig 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 (IdePlugins ls) = mkPlugin (allLspCmdIds pid) (Just . pluginCommands)+ where+ justs (p, Just x) = [(p, x)]+ justs (_, Nothing) = []+++ 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,378 +1,424 @@-{-# 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 +{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}++module Ide.Types+ where++#ifdef mingw32_HOST_OS+import qualified System.Win32.Process as P (getCurrentProcessId)+#else+import qualified System.Posix.Process as P (getProcessID)+import System.Posix.Signals+#endif+import Control.Lens ((^.))+import Control.Monad+import Data.Aeson hiding (defaultOptions)+import qualified Data.DList as DList+import qualified Data.Default+import Data.Dependent.Map (DMap)+import qualified Data.Dependent.Map as DMap+import Data.GADT.Compare+import Data.List.NonEmpty (NonEmpty (..), toList)+import qualified Data.Map as Map+import Data.Maybe+import Data.Semigroup+import Data.String+import qualified Data.Text as T+import Data.Text.Encoding (encodeUtf8)+import Development.Shake hiding (command)+import GHC.Generics+import Ide.Plugin.Config+import Ide.Plugin.Properties+import Language.LSP.Server (LspM, getVirtualFile)+import Language.LSP.Types+import Language.LSP.Types.Capabilities+import Language.LSP.Types.Lens as J hiding (id)+import Language.LSP.VFS+import OpenTelemetry.Eventlog+import System.IO.Unsafe+import Text.Regex.TDFA.Text ()++-- ---------------------------------------------------------------------++newtype IdePlugins ideState = IdePlugins+ { ipMap :: [(PluginId, PluginDescriptor ideState)]}++-- ---------------------------------------------------------------------++data PluginDescriptor ideState =+ PluginDescriptor { pluginId :: !PluginId+ , pluginRules :: !(Rules ())+ , pluginCommands :: ![PluginCommand ideState]+ , pluginHandlers :: PluginHandlers ideState+ , pluginCustomConfig :: CustomConfig+ , pluginNotificationHandlers :: PluginNotificationHandlers ideState+ }++-- | An existential wrapper of 'Properties', used only for documenting and generating config templates+data CustomConfig = forall r. CustomConfig (Properties r)++emptyCustomConfig :: CustomConfig+emptyCustomConfig = CustomConfig emptyProperties++mkCustomConfig :: Properties r -> CustomConfig+mkCustomConfig = CustomConfig++-- | 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 _tags dep (Location _uri range) cont)+ = DocumentSymbol name cont kind Nothing 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) Nothing (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++-- | Methods which have a PluginMethod instance+data IdeNotification (m :: Method FromClient Notification) = HasTracing (MessageParams m) => IdeNotification (SMethod m)+instance GEq IdeNotification where+ geq (IdeNotification a) (IdeNotification b) = geq a b+instance GCompare IdeNotification where+ gcompare (IdeNotification a) (IdeNotification 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 PluginNotificationHandler a (m :: Method FromClient Notification)+ = PluginNotificationHandler (PluginId -> a -> MessageParams m -> LspM Config ())++newtype PluginHandlers a = PluginHandlers (DMap IdeMethod (PluginHandler a))+newtype PluginNotificationHandlers a = PluginNotificationHandlers (DMap IdeNotification (PluginNotificationHandler 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++instance Semigroup (PluginNotificationHandlers a) where+ (PluginNotificationHandlers a) <> (PluginNotificationHandlers b) = PluginNotificationHandlers $ DMap.unionWithKey go a b+ where+ go _ (PluginNotificationHandler f) (PluginNotificationHandler g) = PluginNotificationHandler $ \pid ide params ->+ f pid ide params >> g pid ide params++instance Monoid (PluginNotificationHandlers a) where+ mempty = PluginNotificationHandlers mempty++type PluginMethodHandler a m = a -> PluginId -> MessageParams m -> LspM Config (Either ResponseError (ResponseResult m))++type PluginNotificationMethodHandler a m = a -> PluginId -> MessageParams m -> LspM Config ()++-- | 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++-- | Make a handler for plugins with no extra data+mkPluginNotificationHandler+ :: HasTracing (MessageParams m)+ => SClientMethod (m :: Method FromClient Notification)+ -> PluginNotificationMethodHandler ideState m+ -> PluginNotificationHandlers ideState+mkPluginNotificationHandler m f+ = PluginNotificationHandlers $ DMap.singleton (IdeNotification m) (PluginNotificationHandler f')+ where+ f' pid ide = f ide pid++defaultPluginDescriptor :: PluginId -> PluginDescriptor ideState+defaultPluginDescriptor plId =+ PluginDescriptor+ plId+ mempty+ mempty+ mempty+ emptyCustomConfig+ 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 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