hls-plugin-api 2.2.0.0 → 2.14.0.0
raw patch · 15 files changed
Files
- bench/Main.hs +9/−9
- hls-plugin-api.cabal +38/−29
- src/Ide/Logger.hs +5/−38
- src/Ide/Plugin/Config.hs +6/−3
- src/Ide/Plugin/ConfigUtils.hs +130/−21
- src/Ide/Plugin/Error.hs +11/−11
- src/Ide/Plugin/HandleRequestTypes.hs +46/−0
- src/Ide/Plugin/Properties.hs +143/−39
- src/Ide/Plugin/RangeMap.hs +21/−10
- src/Ide/Plugin/Resolve.hs +25/−36
- src/Ide/PluginUtils.hs +43/−4
- src/Ide/Types.hs +431/−245
- test/Ide/PluginUtilsTest.hs +127/−8
- test/Ide/TypesTests.hs +249/−0
- test/Main.hs +2/−0
bench/Main.hs view
@@ -2,17 +2,17 @@ -- vs RangeMap-based "in-range filtering" approaches module Main (main) where -import Control.DeepSeq (force)-import Control.Exception (evaluate)-import Control.Monad (replicateM)+import Control.DeepSeq (force)+import Control.Exception (evaluate)+import Control.Monad (replicateM) import qualified Criterion import qualified Criterion.Main-import Data.Random (RVar)-import qualified Data.Random as Fu-import qualified Ide.Plugin.RangeMap as RangeMap-import Language.LSP.Types (Position (..), Range (..), UInt,- isSubrangeOf)-import qualified System.Random.Stateful as Random+import Data.Random (RVar)+import qualified Data.Random as Fu+import qualified Ide.Plugin.RangeMap as RangeMap+import Language.LSP.Protocol.Types (Position (..), Range (..), UInt,+ isSubrangeOf)+import qualified System.Random.Stateful as Random genRangeList :: Int -> RVar [Range]
hls-plugin-api.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-plugin-api-version: 2.2.0.0+version: 2.14.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>@@ -32,17 +32,24 @@ type: git location: https://github.com/haskell/haskell-language-server +common warnings+ ghc-options:+ -Wall -Wredundant-constraints -Wunused-packages+ -Wno-name-shadowing -Wno-unticked-promoted-constructors+ library+ import: warnings exposed-modules:- Ide.Plugin.Error+ Ide.Logger Ide.Plugin.Config Ide.Plugin.ConfigUtils+ Ide.Plugin.Error+ Ide.Plugin.HandleRequestTypes Ide.Plugin.Properties Ide.Plugin.RangeMap Ide.Plugin.Resolve Ide.PluginUtils Ide.Types- Ide.Logger hs-source-dirs: src build-depends:@@ -53,29 +60,28 @@ , data-default , dependent-map , dependent-sum >=0.7- , Diff ^>=0.4.0+ , Diff ^>=0.5 || ^>=1.0.0 , dlist , extra , filepath , ghc , hashable- , hls-graph == 2.2.0.0+ , hls-graph == 2.14.0.0 , lens , lens-aeson- , lsp ^>=2.2+ , lsp ^>=2.8+ , megaparsec >=9.0 , mtl , opentelemetry >=0.4 , optparse-applicative , prettyprinter , regex-tdfa >=1.3.1.0- , row-types , stm , text , time , transformers , unliftio , unordered-containers- , megaparsec > 9 if os(windows) build-depends: Win32@@ -83,58 +89,61 @@ else build-depends: unix - ghc-options:- -Wall -Wredundant-constraints -Wno-name-shadowing- -Wno-unticked-promoted-constructors- if flag(pedantic) ghc-options: -Werror- if impl(ghc >= 9)- ghc-options: -Wunused-packages if flag(use-fingertree)- cpp-options: -DUSE_FINGERTREE+ cpp-options: -DUSE_FINGERTREE build-depends: hw-fingertree - default-language: Haskell2010+ default-language: GHC2021 default-extensions: DataKinds- KindSignatures- TypeOperators test-suite tests+ import: warnings type: exitcode-stdio-1.0- default-language: Haskell2010+ default-language: GHC2021 hs-source-dirs: test main-is: Main.hs ghc-options: -threaded -rtsopts -with-rtsopts=-N- other-modules: Ide.PluginUtilsTest+ other-modules:+ Ide.PluginUtilsTest+ Ide.TypesTests+ build-depends:- base+ , bytestring+ , aeson+ , base+ , containers+ , data-default , hls-plugin-api+ , lens+ , lsp-types , tasty+ , tasty-golden , tasty-hunit- , tasty-rerun , tasty-quickcheck+ , tasty-rerun , text- , lsp-types- , containers benchmark rangemap-benchmark+ import: warnings -- Benchmark doesn't make sense if fingertree implementation -- is not used. if !flag(use-fingertree) buildable: False+ type: exitcode-stdio-1.0- default-language: Haskell2010+ default-language: GHC2021 hs-source-dirs: bench main-is: Main.hs- ghc-options: -threaded -Wall+ ghc-options: -threaded build-depends:- base+ , base+ , criterion+ , deepseq , hls-plugin-api , lsp-types- , criterion , random , random-fu- , deepseq
src/Ide/Logger.hs view
@@ -1,23 +1,16 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 -{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-} -- | This is a compatibility module that abstracts over the -- concrete choice of logging framework so users can plug in whatever -- framework they want to. module Ide.Logger ( Priority(..)- , Logger(..) , Recorder(..)- , logError, logWarning, logInfo, logDebug- , noLogging , WithPriority(..) , logWith , cmap@@ -34,6 +27,7 @@ , module PrettyPrinterModule , renderStrict , toCologActionWithPrio+ , defaultLoggingColumns ) where import Colog.Core (LogAction (..), Severity,@@ -52,7 +46,6 @@ import Data.Functor.Contravariant (Contravariant (contramap)) import Data.Maybe (fromMaybe) import Data.Text (Text)-import qualified Data.Text as T import qualified Data.Text as Text import qualified Data.Text.IO as Text import Data.Time (defaultTimeLocale, formatTime,@@ -85,32 +78,6 @@ | Error -- ^ Such log messages must never occur in expected usage. deriving (Eq, Show, Read, Ord, Enum, Bounded) --- | Note that this is logging actions _of the program_, not of the user.--- You shouldn't call warning/error if the user has caused an error, only--- if our code has gone wrong and is itself erroneous (e.g. we threw an exception).-newtype Logger = Logger {logPriority :: Priority -> T.Text -> IO ()}--instance Semigroup Logger where- l1 <> l2 = Logger $ \p t -> logPriority l1 p t >> logPriority l2 p t--instance Monoid Logger where- mempty = Logger $ \_ _ -> pure ()--logError :: Logger -> T.Text -> IO ()-logError x = logPriority x Error--logWarning :: Logger -> T.Text -> IO ()-logWarning x = logPriority x Warning--logInfo :: Logger -> T.Text -> IO ()-logInfo x = logPriority x Info--logDebug :: Logger -> T.Text -> IO ()-logDebug x = logPriority x Debug--noLogging :: Logger-noLogging = Logger $ \_ _ -> return ()- data WithPriority a = WithPriority { priority :: Priority, callStack_ :: CallStack, payload :: a } deriving Functor -- | Note that this is logging actions _of the program_, not of the user.@@ -178,7 +145,7 @@ fileHandle :: Either IOException Handle <- liftIO $ try (openFile path AppendMode) case fileHandle of Left e -> action $ Left e- Right fileHandle -> finally ((Right <$> makeHandleRecorder fileHandle) >>= action) (liftIO $ hClose fileHandle)+ Right fileHandle -> finally (makeHandleRecorder fileHandle >>= action . Right) (liftIO $ hClose fileHandle) makeDefaultHandleRecorder :: MonadIO m
src/Ide/Plugin/Config.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-}@@ -43,6 +42,7 @@ <*> o .:? "formattingProvider" .!= formattingProvider defValue <*> o .:? "cabalFormattingProvider" .!= cabalFormattingProvider defValue <*> o .:? "maxCompletions" .!= maxCompletions defValue+ <*> o .:? "sessionLoading" .!= sessionLoading defValue <*> A.explicitParseFieldMaybe (parsePlugins idePlugins) o "plugin" .!= plugins defValue -- | Parse the 'PluginConfig'.@@ -63,18 +63,21 @@ -- --------------------------------------------------------------------- parsePluginConfig :: PluginConfig -> Value -> A.Parser PluginConfig-parsePluginConfig def = A.withObject "PluginConfig" $ \o -> PluginConfig+parsePluginConfig def = A.withObject "PluginConfig" $ \o -> PluginConfig <$> o .:? "globalOn" .!= plcGlobalOn def <*> o .:? "callHierarchyOn" .!= plcCallHierarchyOn def <*> o .:? "codeActionsOn" .!= plcCodeActionsOn def <*> o .:? "codeLensOn" .!= plcCodeLensOn def+ <*> o .:? "inlayHintsOn" .!= plcInlayHintsOn def <*> o .:? "diagnosticsOn" .!= plcDiagnosticsOn def -- AZ <*> o .:? "hoverOn" .!= plcHoverOn def <*> o .:? "symbolsOn" .!= plcSymbolsOn def+ <*> o .:? "signatureHelpOn" .!= plcSignatureHelpOn def <*> o .:? "completionOn" .!= plcCompletionOn def <*> o .:? "renameOn" .!= plcRenameOn def <*> o .:? "selectionRangeOn" .!= plcSelectionRangeOn def- <*> o .:? "foldingRangeOn" .!= plcFoldingRangeOn def+ <*> o .:? "foldingRangeOn" .!= plcFoldingRangeOn def+ <*> o .:? "semanticTokensOn" .!= plcSemanticTokensOn def <*> o .:? "config" .!= plcConfig def -- ---------------------------------------------------------------------
src/Ide/Plugin/ConfigUtils.hs view
@@ -3,7 +3,11 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} -module Ide.Plugin.ConfigUtils where+module Ide.Plugin.ConfigUtils (+ pluginsToDefaultConfig,+ pluginsToVSCodeExtensionSchema,+ pluginsCustomConfigToMarkdownTables+ ) where import Control.Lens (at, (&), (?~)) import qualified Data.Aeson as A@@ -15,8 +19,15 @@ import Data.List.Extra (nubOrd) import Data.String (IsString (fromString)) import qualified Data.Text as T+import GHC.TypeLits (symbolVal) import Ide.Plugin.Config-import Ide.Plugin.Properties (toDefaultJSON,+import Ide.Plugin.Properties (KeyNameProxy, MetaData (..),+ PluginCustomConfig (..),+ PluginCustomConfigParam (..),+ Properties (..),+ SPropertyKey (..),+ SomePropertyKeyWithMetaData (..),+ toDefaultJSON, toVSCodeExtensionSchema) import Ide.Types import Language.LSP.Protocol.Message@@ -31,10 +42,10 @@ pluginsToDefaultConfig IdePlugins {..} = -- Use '_Object' and 'at' to get at the "plugin" key -- and actually set it.- A.toJSON defaultConfig & _Object . at "plugin" ?~ elems+ A.toJSON defaultConfig & _Object . at "plugin" ?~ pluginSpecificDefaultConfigs where- defaultConfig@Config {} = def- elems = A.object $ mconcat $ singlePlugin <$> ipMap+ defaultConfig = def :: Config+ pluginSpecificDefaultConfigs = A.object $ mconcat $ singlePlugin <$> ipMap -- Splice genericDefaultConfig and dedicatedDefaultConfig -- Example: --@@ -48,6 +59,7 @@ -- } -- } -- }+ singlePlugin :: PluginDescriptor ideState -> [A.Pair] singlePlugin PluginDescriptor {pluginConfigDescriptor = ConfigDescriptor {..}, ..} = let x = genericDefaultConfig <> dedicatedDefaultConfig in [fromString (T.unpack pId) A..= A.object x | not $ null x]@@ -66,8 +78,8 @@ <> nubOrd (mconcat (handlersToGenericDefaultConfig configInitialGenericConfig <$> handlers)) in case x of- -- if the plugin has only one capability, we produce globalOn instead of the specific one;- -- otherwise we don't produce globalOn at all+ -- If the plugin has only one capability, we produce globalOn instead of the specific one;+ -- otherwise we omit globalOn [_] -> ["globalOn" A..= plcGlobalOn configInitialGenericConfig] _ -> x -- Example:@@ -88,11 +100,15 @@ handlersToGenericDefaultConfig PluginConfig{..} (IdeMethod m DSum.:=> _) = case m of SMethod_TextDocumentCodeAction -> ["codeActionsOn" A..= plcCodeActionsOn] SMethod_TextDocumentCodeLens -> ["codeLensOn" A..= plcCodeLensOn]+ SMethod_TextDocumentInlayHint -> ["inlayHintsOn" A..= plcInlayHintsOn] SMethod_TextDocumentRename -> ["renameOn" A..= plcRenameOn] SMethod_TextDocumentHover -> ["hoverOn" A..= plcHoverOn] SMethod_TextDocumentDocumentSymbol -> ["symbolsOn" A..= plcSymbolsOn]+ SMethod_TextDocumentSignatureHelp -> ["signatureHelpOn" A..= plcSignatureHelpOn] SMethod_TextDocumentCompletion -> ["completionOn" A..= plcCompletionOn] SMethod_TextDocumentPrepareCallHierarchy -> ["callHierarchyOn" A..= plcCallHierarchyOn]+ SMethod_TextDocumentSemanticTokensFull -> ["semanticTokensOn" A..= plcSemanticTokensOn]+ SMethod_TextDocumentSemanticTokensFullDelta -> ["semanticTokensOn" A..= plcSemanticTokensOn] _ -> [] -- | Generates json schema used in haskell vscode extension@@ -107,29 +123,122 @@ (PluginId pId) = pluginId genericSchema = let x =- [toKey' "diagnosticsOn" A..= schemaEntry "diagnostics" | configHasDiagnostics]- <> nubOrd (mconcat (handlersToGenericSchema <$> handlers))+ [toKey' "diagnosticsOn" A..= schemaEntry "diagnostics" True | configHasDiagnostics]+ <> nubOrd (mconcat (handlersToGenericSchema configInitialGenericConfig <$> handlers)) in case x of -- If the plugin has only one capability, we produce globalOn instead of the specific one; -- otherwise we don't produce globalOn at all- [_] -> [toKey' "globalOn" A..= schemaEntry "plugin"]+ [_] -> [toKey' "globalOn" A..= schemaEntry "plugin" (plcGlobalOn configInitialGenericConfig)] _ -> x dedicatedSchema = customConfigToDedicatedSchema configCustomConfig- handlersToGenericSchema (IdeMethod m DSum.:=> _) = case m of- SMethod_TextDocumentCodeAction -> [toKey' "codeActionsOn" A..= schemaEntry "code actions"]- SMethod_TextDocumentCodeLens -> [toKey' "codeLensOn" A..= schemaEntry "code lenses"]- SMethod_TextDocumentRename -> [toKey' "renameOn" A..= schemaEntry "rename"]- SMethod_TextDocumentHover -> [toKey' "hoverOn" A..= schemaEntry "hover"]- SMethod_TextDocumentDocumentSymbol -> [toKey' "symbolsOn" A..= schemaEntry "symbols"]- SMethod_TextDocumentCompletion -> [toKey' "completionOn" A..= schemaEntry "completions"]- SMethod_TextDocumentPrepareCallHierarchy -> [toKey' "callHierarchyOn" A..= schemaEntry "call hierarchy"]- _ -> []- schemaEntry desc =+ handlersToGenericSchema PluginConfig{..} (IdeMethod m DSum.:=> _) = case m of+ SMethod_TextDocumentCodeAction -> [toKey' "codeActionsOn" A..= schemaEntry "code actions" plcCodeActionsOn]+ SMethod_TextDocumentCodeLens -> [toKey' "codeLensOn" A..= schemaEntry "code lenses" plcCodeLensOn]+ SMethod_TextDocumentInlayHint -> [toKey' "inlayHintsOn" A..= schemaEntry "inlay hints" plcInlayHintsOn]+ SMethod_TextDocumentRename -> [toKey' "renameOn" A..= schemaEntry "rename" plcRenameOn]+ SMethod_TextDocumentHover -> [toKey' "hoverOn" A..= schemaEntry "hover" plcHoverOn]+ SMethod_TextDocumentDocumentSymbol -> [toKey' "symbolsOn" A..= schemaEntry "symbols" plcSymbolsOn]+ SMethod_TextDocumentSignatureHelp -> [toKey' "signatureHelpOn" A..= schemaEntry "signature help" plcSignatureHelpOn]+ SMethod_TextDocumentCompletion -> [toKey' "completionOn" A..= schemaEntry "completions" plcCompletionOn]+ SMethod_TextDocumentPrepareCallHierarchy -> [toKey' "callHierarchyOn" A..= schemaEntry "call hierarchy" plcCallHierarchyOn]+ SMethod_TextDocumentSemanticTokensFull -> [toKey' "semanticTokensOn" A..= schemaEntry "semantic tokens" plcSemanticTokensOn]+ SMethod_TextDocumentSemanticTokensFullDelta -> [toKey' "semanticTokensOn" A..= schemaEntry "semantic tokens" plcSemanticTokensOn]+ _ -> []+ schemaEntry desc defaultVal = A.object [ "scope" A..= A.String "resource", "type" A..= A.String "boolean",- "default" A..= True,+ "default" A..= A.Bool defaultVal, "description" A..= A.String ("Enables " <> pId <> " " <> desc) ] withIdPrefix x = "haskell.plugin." <> pId <> "." <> x toKey' = fromString . T.unpack . withIdPrefix+++-- | Generates markdown tables for custom config+pluginsCustomConfigToMarkdownTables :: IdePlugins a -> T.Text+pluginsCustomConfigToMarkdownTables IdePlugins {..} = T.unlines+ $ map renderCfg+ $ filter (\(PluginCustomConfig _ params) -> not $ null params)+ $ map toPluginCustomConfig ipMap+ where+ toPluginCustomConfig :: PluginDescriptor ideState -> PluginCustomConfig+ toPluginCustomConfig PluginDescriptor {pluginConfigDescriptor = ConfigDescriptor {configCustomConfig = c}, pluginId = PluginId pId} =+ PluginCustomConfig { pcc'Name = pId, pcc'Params = toPluginCustomConfigParams c}+ toPluginCustomConfigParams :: CustomConfig -> [PluginCustomConfigParam]+ toPluginCustomConfigParams (CustomConfig p) = toPluginCustomConfigParams' p+ toPluginCustomConfigParams' :: Properties r -> [PluginCustomConfigParam]+ toPluginCustomConfigParams' EmptyProperties = []+ toPluginCustomConfigParams' (ConsProperties (keyNameProxy :: KeyNameProxy s) (k :: SPropertyKey k) (m :: MetaData t) xs) =+ toEntry (SomePropertyKeyWithMetaData k m) : toPluginCustomConfigParams' xs+ where+ toEntry :: SomePropertyKeyWithMetaData -> PluginCustomConfigParam+ toEntry (SomePropertyKeyWithMetaData SNumber MetaData {..}) =+ PluginCustomConfigParam {+ pccp'Name = T.pack $ symbolVal keyNameProxy,+ pccp'Description = description,+ pccp'Default = T.pack $ show defaultValue,+ pccp'EnumValues = []+ }+ toEntry (SomePropertyKeyWithMetaData SInteger MetaData {..}) =+ PluginCustomConfigParam {+ pccp'Name = T.pack $ symbolVal keyNameProxy,+ pccp'Description = description,+ pccp'Default = T.pack $ show defaultValue,+ pccp'EnumValues = []+ }+ toEntry (SomePropertyKeyWithMetaData SString MetaData {..}) =+ PluginCustomConfigParam {+ pccp'Name = T.pack $ symbolVal keyNameProxy,+ pccp'Description = description,+ pccp'Default = T.pack $ show defaultValue,+ pccp'EnumValues = []+ }+ toEntry (SomePropertyKeyWithMetaData SBoolean MetaData {..}) =+ PluginCustomConfigParam {+ pccp'Name = T.pack $ symbolVal keyNameProxy,+ pccp'Description = description,+ pccp'Default = T.pack $ show defaultValue,+ pccp'EnumValues = []+ }+ toEntry (SomePropertyKeyWithMetaData (SObject _) MetaData {..}) =+ PluginCustomConfigParam {+ pccp'Name = T.pack $ symbolVal keyNameProxy,+ pccp'Description = description,+ pccp'Default = "TODO: nested object", -- T.pack $ show defaultValue,+ pccp'EnumValues = []+ }+ toEntry (SomePropertyKeyWithMetaData (SArray _) MetaData {..}) =+ PluginCustomConfigParam {+ pccp'Name = T.pack $ symbolVal keyNameProxy,+ pccp'Description = description,+ pccp'Default = "TODO: Array values", -- T.pack $ show defaultValue,+ pccp'EnumValues = []+ }+ toEntry (SomePropertyKeyWithMetaData (SEnum _) EnumMetaData {..}) =+ PluginCustomConfigParam {+ pccp'Name = T.pack $ symbolVal keyNameProxy,+ pccp'Description = description,+ pccp'Default = T.pack $ show defaultValue,+ pccp'EnumValues = map (T.pack . show) enumValues+ }+ toEntry (SomePropertyKeyWithMetaData SProperties PropertiesMetaData {..}) =+ PluginCustomConfigParam {+ pccp'Name = T.pack $ symbolVal keyNameProxy,+ pccp'Description = description,+ pccp'Default = T.pack $ show defaultValue,+ pccp'EnumValues = []+ }+ renderCfg :: PluginCustomConfig -> T.Text+ renderCfg (PluginCustomConfig pId pccParams) =+ T.unlines (pluginHeader : tableHeader : rows pccParams)+ where+ pluginHeader = "## " <> pId+ tableHeader =+ "| Property | Description | Default | Allowed values |" <> "\n" <>+ "| --- | --- | --- | --- |"+ rows = map renderRow+ renderRow PluginCustomConfigParam {..} =+ "| `" <> pccp'Name <> "` | " <> pccp'Description <> " | `" <> pccp'Default <> "` | " <> renderEnum pccp'EnumValues <> " |"+ renderEnum [] = " " -- Placeholder to prevent missing cells+ renderEnum vs = "<ul> " <> (T.intercalate " " $ map (\x -> "<li><code>" <> x <> "</code></li>") vs) <> " </ul>"
src/Ide/Plugin/Error.hs view
@@ -1,6 +1,5 @@-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-} module Ide.Plugin.Error ( -- * Plugin Error Handling API PluginError(..),@@ -11,11 +10,12 @@ getNormalizedFilePathE, ) where -import Control.Monad.Extra (maybeM)-import Control.Monad.Trans.Class (lift)-import Control.Monad.Trans.Except (ExceptT (..), throwE)-import qualified Data.Text as T+import Control.Monad.Extra (maybeM)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Except (ExceptT (..), throwE)+import qualified Data.Text as T import Ide.Logger+import Ide.Plugin.HandleRequestTypes (RejectionReason) import Language.LSP.Protocol.Types -- ----------------------------------------------------------------------------@@ -79,13 +79,13 @@ | PluginInvalidUserState T.Text -- |PluginRequestRefused allows your handler to inspect a request before -- rejecting it. In effect it allows your plugin to act make a secondary- -- `pluginEnabled` decision after receiving the request. This should only be+ -- `handlesRequest` decision after receiving the request. This should only be -- used if the decision to accept the request can not be made in- -- `pluginEnabled`.+ -- `handlesRequest`. -- -- This error will be with Debug. If it's the only response to a request,- -- HLS will respond as if no plugins passed the `pluginEnabled` stage.- | PluginRequestRefused T.Text+ -- HLS will respond as if no plugins passed the `handlesRequest` stage.+ | PluginRequestRefused RejectionReason -- |PluginRuleFailed should be thrown when a Rule your response depends on -- fails. --
+ src/Ide/Plugin/HandleRequestTypes.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE OverloadedStrings #-}++module Ide.Plugin.HandleRequestTypes where++import Data.Text+import Prettyprinter++-- | Reasons why a plugin could reject a specific request.+data RejectionReason =+ -- | The resolve request is not meant for this plugin or handler. The text+ -- field should contain the identifier for the plugin who owns this resolve+ -- request.+ NotResolveOwner Text+ -- | The plugin is disabled globally in the users config.+ | DisabledGlobally+ -- | The feature in the plugin that responds to this request is disabled in+ -- the users config+ | FeatureDisabled+ -- | This plugin is not the formatting provider selected in the users config.+ -- The text should be the formatting provider in your config.+ | NotFormattingProvider Text+ -- | This plugin does not support the file type. The text field here should+ -- contain the filetype of the rejected request.+ | DoesNotSupportFileType Text+ deriving (Eq)++-- | Whether a plugin will handle a request or not.+data HandleRequestResult = HandlesRequest | DoesNotHandleRequest RejectionReason+ deriving (Eq)++instance Pretty HandleRequestResult where+ pretty HandlesRequest = "handles this request"+ pretty (DoesNotHandleRequest reason) = pretty reason++instance Pretty RejectionReason where+ pretty (NotResolveOwner s) = "does not handle resolve requests for " <> pretty s <> ")."+ pretty DisabledGlobally = "is disabled globally in your config."+ pretty FeatureDisabled = "'s feature that handles this request is disabled in your config."+ pretty (NotFormattingProvider s) = "is not the formatting provider ("<> pretty s<>") you chose in your config."+ pretty (DoesNotSupportFileType s) = "does not support " <> pretty s <> " filetypes)."++-- We always want to keep the leftmost disabled reason+instance Semigroup HandleRequestResult where+ HandlesRequest <> HandlesRequest = HandlesRequest+ DoesNotHandleRequest r <> _ = DoesNotHandleRequest r+ _ <> DoesNotHandleRequest r = DoesNotHandleRequest r
src/Ide/Plugin/Properties.hs view
@@ -6,23 +6,27 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}--- See Note [Constraints]-{-# OPTIONS_GHC -Wno-redundant-constraints #-} + module Ide.Plugin.Properties ( PropertyType (..), ToHsType,+ NotElem, MetaData (..), PropertyKey (..), SPropertyKey (..),+ SomePropertyKeyWithMetaData (..), KeyNameProxy (..),- Properties,+ KeyNamePath (..),+ Properties(..), HasProperty,+ HasPropertyByPath, emptyProperties, defineNumberProperty, defineIntegerProperty,@@ -31,27 +35,32 @@ defineObjectProperty, defineArrayProperty, defineEnumProperty,+ definePropertiesProperty, toDefaultJSON, toVSCodeExtensionSchema, usePropertyEither, useProperty,+ usePropertyByPathEither,+ usePropertyByPath, (&),+ PluginCustomConfig(..),+ PluginCustomConfigParam(..), ) where +import Control.Arrow (first) 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 Data.String (IsString (fromString)) import qualified Data.Text as T import GHC.OverloadedLabels (IsLabel (..)) import GHC.TypeLits-import Unsafe.Coerce (unsafeCoerce) + -- | Types properties may have data PropertyType = TNumber@@ -61,6 +70,7 @@ | TObject Type | TArray Type | TEnum Type+ | TProperties [PropertyKey] -- ^ A typed TObject, defined in a recursive manner type family ToHsType (t :: PropertyType) where ToHsType 'TNumber = Double -- in js, there are no distinct types for integers and floating-point values@@ -70,13 +80,14 @@ ToHsType ('TObject a) = a ToHsType ('TArray a) = [a] ToHsType ('TEnum a) = a+ ToHsType ('TProperties _) = A.Object -- --------------------------------------------------------------------- -- | Metadata of a property data MetaData (t :: PropertyType) where MetaData ::- (IsTEnum t ~ 'False) =>+ (IsTEnum t ~ 'False, IsProperties t ~ 'False) => { defaultValue :: ToHsType t, description :: T.Text } ->@@ -89,7 +100,16 @@ enumDescriptions :: [T.Text] } -> MetaData t+ PropertiesMetaData ::+ (t ~ TProperties rs) =>+ {+ defaultValue :: ToHsType t+ , description :: T.Text+ , childrenProperties :: Properties rs+ } ->+ MetaData t + -- | Used at type level for name-type mapping in 'Properties' data PropertyKey = PropertyKey Symbol PropertyType @@ -102,6 +122,7 @@ 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))+ SProperties :: SPropertyKey ('PropertyKey s ('TProperties pp)) -- | Existential wrapper of 'SPropertyKey', with an extra 'MetaData' data SomePropertyKeyWithMetaData@@ -110,11 +131,14 @@ 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.+-- In hls, it defines a set of properties 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)+data Properties (r :: [PropertyKey]) where+ ConsProperties :: (k ~ 'PropertyKey s t, KnownSymbol s, NotElem s ks)+ => KeyNameProxy s -> (SPropertyKey k) -> (MetaData t) -> Properties ks -> Properties (k : ks)+ EmptyProperties :: Properties '[] -- | A proxy type in order to allow overloaded labels as properties' names at the call site data KeyNameProxy (s :: Symbol) = KnownSymbol s => KeyNameProxy@@ -122,16 +146,61 @@ instance (KnownSymbol s', s ~ s') => IsLabel s (KeyNameProxy s') where fromLabel = KeyNameProxy +data NonEmptyList a =+ a :| NonEmptyList a | NE a++-- | a path to a property in a json object+data KeyNamePath (r :: NonEmptyList Symbol) where+ SingleKey :: KeyNameProxy s -> KeyNamePath (NE s)+ ConsKeysPath :: KeyNameProxy s1 -> KeyNamePath ss -> KeyNamePath (s1 :| ss)++class ParsePropertyPath (rs :: [PropertyKey]) (r :: NonEmptyList Symbol) where+ usePropertyByPathEither :: KeyNamePath r -> Properties rs -> A.Object -> Either String (ToHsType (FindByKeyPath r rs))+ useDefault :: KeyNamePath r -> Properties rs -> ToHsType (FindByKeyPath r rs)+ usePropertyByPath :: KeyNamePath r -> Properties rs -> A.Object -> ToHsType (FindByKeyPath r rs)+ usePropertyByPath p ps x = fromRight (useDefault p ps) $ usePropertyByPathEither p ps x++instance (HasProperty s k t r) => ParsePropertyPath r (NE s) where+ usePropertyByPathEither (SingleKey kn) sm x = parseProperty kn (find kn sm) x+ useDefault (SingleKey kn) sm = defaultValue metadata+ where (_, metadata) = find kn sm++instance ( ToHsType (FindByKeyPath ss r2) ~ ToHsType (FindByKeyPath (s :| ss) r)+ ,HasProperty s ('PropertyKey s ('TProperties r2)) t2 r+ , ParsePropertyPath r2 ss)+ => ParsePropertyPath r (s :| ss) where+ usePropertyByPathEither (ConsKeysPath kn p) sm x = do+ let (key, meta) = find kn sm+ interMedia <- parseProperty kn (key, meta) x+ case meta of+ PropertiesMetaData {..}+ -> usePropertyByPathEither p childrenProperties interMedia+ useDefault (ConsKeysPath kn p) sm = case find kn sm of+ (_, PropertiesMetaData {..}) -> useDefault p childrenProperties+ -- --------------------------------------------------------------------- +type family IsProperties (t :: PropertyType) :: Bool where+ IsProperties ('TProperties pp) = 'True+ IsProperties _ = 'False+ type family IsTEnum (t :: PropertyType) :: Bool where IsTEnum ('TEnum _) = 'True IsTEnum _ = 'False +type family FindByKeyPath (ne :: NonEmptyList Symbol) (r :: [PropertyKey]) :: PropertyType where+ FindByKeyPath (s :| xs) ('PropertyKey s ('TProperties rs) ': _) = FindByKeyPath xs rs+ FindByKeyPath (s :| xs) (_ ': ys) = FindByKeyPath (s :| xs) ys+ FindByKeyPath (NE s) ys = FindByKeyName s ys+ type family FindByKeyName (s :: Symbol) (r :: [PropertyKey]) :: PropertyType where FindByKeyName s ('PropertyKey s t ': _) = t FindByKeyName s (_ ': xs) = FindByKeyName s xs +type family IsPropertySymbol (s :: Symbol) (r :: PropertyKey) :: Bool where+ IsPropertySymbol s ('PropertyKey s _) = 'True+ IsPropertySymbol s _ = 'False+ type family Elem (s :: Symbol) (r :: [PropertyKey]) :: Constraint where Elem s ('PropertyKey s _ ': _) = () Elem s (_ ': xs) = Elem s xs@@ -142,8 +211,21 @@ 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)+type HasProperty s k t r = (k ~ 'PropertyKey s t, Elem s r, FindByKeyPath (NE s) r ~ t, FindByKeyName s r ~ t, KnownSymbol s, FindPropertyMeta s r t)+-- similar to HasProperty, but the path is given as a type-level list of symbols+type HasPropertyByPath props path t = (t ~ FindByKeyPath path props, ParsePropertyPath props path)+class FindPropertyMeta (s :: Symbol) (r :: [PropertyKey]) t where+ findSomePropertyKeyWithMetaData :: KeyNameProxy s -> Properties r -> (SPropertyKey ('PropertyKey s t), MetaData t)+instance (FindPropertyMetaIf (IsPropertySymbol symbol k) symbol k ks t) => FindPropertyMeta symbol (k : ks) t where+ findSomePropertyKeyWithMetaData = findSomePropertyKeyWithMetaDataIf+class (bool ~ IsPropertySymbol symbol k) => FindPropertyMetaIf bool symbol k ks t where+ findSomePropertyKeyWithMetaDataIf :: KeyNameProxy symbol -> Properties (k : ks) -> (SPropertyKey ('PropertyKey symbol t), MetaData t)+instance (k ~ 'PropertyKey s t) => FindPropertyMetaIf 'True s k ks t where+ findSomePropertyKeyWithMetaDataIf _ (ConsProperties _ k m _) = (k, m)+instance ('False ~ IsPropertySymbol s k, FindPropertyMeta s ks t) => FindPropertyMetaIf 'False s k ks t where+ findSomePropertyKeyWithMetaDataIf s (ConsProperties _ _ _ ks) = findSomePropertyKeyWithMetaData s ks -- --------------------------------------------------------------------- @@ -164,7 +246,7 @@ -- @ emptyProperties :: Properties '[]-emptyProperties = Properties Map.empty+emptyProperties = EmptyProperties insert :: (k ~ 'PropertyKey s t, NotElem s r, KnownSymbol s) =>@@ -173,30 +255,14 @@ MetaData t -> Properties r -> Properties (k ': r)-insert kn key metadata (Properties old) =- Properties- ( Map.insert- (symbolVal kn)- (SomePropertyKeyWithMetaData key metadata)- old- )+insert = ConsProperties 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)+find = findSomePropertyKeyWithMetaData -- --------------------------------------------------------------------- @@ -227,6 +293,7 @@ A.Object -> Either String (ToHsType t) parseProperty kn k x = case k of+ (SProperties, _) -> parseEither (SNumber, _) -> parseEither (SInteger, _) -> parseEither (SString, _) -> parseEither@@ -346,11 +413,24 @@ defineEnumProperty kn description enums defaultValue = insert kn (SEnum Proxy) $ EnumMetaData defaultValue description (fst <$> enums) (snd <$> enums) +definePropertiesProperty ::+ (KnownSymbol s, NotElem s r) =>+ KeyNameProxy s ->+ T.Text ->+ Properties childrenProps ->+ Properties r ->+ Properties ('PropertyKey s ('TProperties childrenProps) : r)+definePropertiesProperty kn description ps rs =+ insert kn SProperties (PropertiesMetaData mempty description ps) rs+ -- --------------------------------------------------------------------- -- | 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]+toDefaultJSON pr = case pr of+ EmptyProperties -> []+ ConsProperties keyNameProxy k m xs ->+ toEntry (symbolVal keyNameProxy) (SomePropertyKeyWithMetaData k m) : toDefaultJSON xs where toEntry :: String -> SomePropertyKeyWithMetaData -> A.Pair toEntry s = \case@@ -368,58 +448,68 @@ fromString s A..= defaultValue (SomePropertyKeyWithMetaData (SEnum _) EnumMetaData {..}) -> fromString s A..= defaultValue+ (SomePropertyKeyWithMetaData SProperties PropertiesMetaData {..}) ->+ fromString s A..= A.object (toDefaultJSON childrenProperties) -- | Converts a properties definition into kv pairs as vscode schema toVSCodeExtensionSchema :: T.Text -> Properties r -> [A.Pair]-toVSCodeExtensionSchema prefix (Properties p) =- [fromString (T.unpack prefix <> k) A..= toEntry v | (k, v) <- Map.toList p]+toVSCodeExtensionSchema prefix p = [fromString (T.unpack prefix <> fromString k) A..= v | (k, v) <- toVSCodeExtensionSchema' p]+toVSCodeExtensionSchema' :: Properties r -> [(String, A.Value)]+toVSCodeExtensionSchema' ps = case ps of+ EmptyProperties -> []+ ConsProperties (keyNameProxy :: KeyNameProxy s) (k :: SPropertyKey k) (m :: MetaData t) xs ->+ [(symbolVal keyNameProxy <> maybe "" ((<>) ".") k1, v)+ | (k1, v) <- toEntry (SomePropertyKeyWithMetaData k m) ]+ ++ toVSCodeExtensionSchema' xs where- toEntry :: SomePropertyKeyWithMetaData -> A.Value+ wrapEmpty :: A.Value -> [(Maybe String, A.Value)]+ wrapEmpty v = [(Nothing, v)]+ toEntry :: SomePropertyKeyWithMetaData -> [(Maybe String, A.Value)] toEntry = \case (SomePropertyKeyWithMetaData SNumber MetaData {..}) ->- A.object+ wrapEmpty $ A.object [ "type" A..= A.String "number", "markdownDescription" A..= description, "default" A..= defaultValue, "scope" A..= A.String "resource" ] (SomePropertyKeyWithMetaData SInteger MetaData {..}) ->- A.object+ wrapEmpty $ A.object [ "type" A..= A.String "integer", "markdownDescription" A..= description, "default" A..= defaultValue, "scope" A..= A.String "resource" ] (SomePropertyKeyWithMetaData SString MetaData {..}) ->- A.object+ wrapEmpty $ A.object [ "type" A..= A.String "string", "markdownDescription" A..= description, "default" A..= defaultValue, "scope" A..= A.String "resource" ] (SomePropertyKeyWithMetaData SBoolean MetaData {..}) ->- A.object+ wrapEmpty $ A.object [ "type" A..= A.String "boolean", "markdownDescription" A..= description, "default" A..= defaultValue, "scope" A..= A.String "resource" ] (SomePropertyKeyWithMetaData (SObject _) MetaData {..}) ->- A.object+ wrapEmpty $ A.object [ "type" A..= A.String "object", "markdownDescription" A..= description, "default" A..= defaultValue, "scope" A..= A.String "resource" ] (SomePropertyKeyWithMetaData (SArray _) MetaData {..}) ->- A.object+ wrapEmpty $ A.object [ "type" A..= A.String "array", "markdownDescription" A..= description, "default" A..= defaultValue, "scope" A..= A.String "resource" ] (SomePropertyKeyWithMetaData (SEnum _) EnumMetaData {..}) ->- A.object+ wrapEmpty $ A.object [ "type" A..= A.String "string", "description" A..= description, "enum" A..= enumValues,@@ -427,3 +517,17 @@ "default" A..= defaultValue, "scope" A..= A.String "resource" ]+ (SomePropertyKeyWithMetaData SProperties PropertiesMetaData {..}) ->+ map (first Just) $ toVSCodeExtensionSchema' childrenProperties++data PluginCustomConfig = PluginCustomConfig {+ pcc'Name :: T.Text,+ pcc'Params :: [PluginCustomConfigParam]+}+data PluginCustomConfigParam = PluginCustomConfigParam {+ pccp'Name :: T.Text,+ pccp'Description :: T.Text,+ pccp'Default :: T.Text,+ pccp'EnumValues :: [T.Text]+}+
src/Ide/Plugin/RangeMap.hs view
@@ -1,9 +1,5 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DerivingStrategies #-} -- | A map that allows fast \"in-range\" filtering. 'RangeMap' is meant -- to be constructed once and cached as part of a Shake rule. If@@ -17,17 +13,24 @@ fromList, fromList', filterByRange,+ elementsInRange, ) where -import Data.Bifunctor (first)-import Data.Foldable (foldl') import Development.IDE.Graph.Classes (NFData)-import Language.LSP.Protocol.Types (Position,- Range (Range))+ #ifdef USE_FINGERTREE+import Data.Bifunctor (first) import qualified HaskellWorks.Data.IntervalMap.FingerTree as IM+import Language.LSP.Protocol.Types (Position,+ Range (Range))+#else+import Language.LSP.Protocol.Types (Range, isSubrangeOf) #endif +#if USE_FINGERTREE && !MIN_VERSION_base(4,20,0)+import Data.List (foldl')+#endif+ -- | A map from code ranges to values. #ifdef USE_FINGERTREE newtype RangeMap a = RangeMap@@ -63,6 +66,14 @@ filterByRange range = map snd . IM.dominators (rangeToInterval range) . unRangeMap #else filterByRange range = map snd . filter (isSubrangeOf range . fst) . unRangeMap+#endif++-- | Extracts all elements from a 'RangeMap' that fall within a given 'Range'.+elementsInRange :: Range -> RangeMap a -> [a]+#ifdef USE_FINGERTREE+elementsInRange range = map snd . IM.intersections (rangeToInterval range) . unRangeMap+#else+elementsInRange range = map snd . filter (flip isSubrangeOf range . fst) . unRangeMap #endif #ifdef USE_FINGERTREE
src/Ide/Plugin/Resolve.hs view
@@ -1,11 +1,6 @@-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-} {-| This module currently includes helper functions to provide fallback support to code actions that use resolve in HLS. The difference between the two functions for code actions that don't support resolve is that@@ -26,11 +21,10 @@ (^?)) import Control.Monad.Error.Class (MonadError (throwError)) import Control.Monad.Trans.Class (lift)-import Control.Monad.Trans.Except (ExceptT (..), runExceptT)+import Control.Monad.Trans.Except (ExceptT (..)) import qualified Data.Aeson as A import Data.Maybe (catMaybes)-import Data.Row ((.!)) import qualified Data.Text as T import GHC.Generics (Generic) import Ide.Logger@@ -39,15 +33,10 @@ import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types-import Language.LSP.Server (LspT,- ProgressCancellable (Cancellable),- getClientCapabilities,- sendRequest,- withIndefiniteProgress) data Log = DoesNotSupportResolve T.Text- | ApplyWorkspaceEditFailed ResponseError+ | forall m . A.ToJSON (ErrorData m) => ApplyWorkspaceEditFailed (TResponseError m) instance Pretty Log where pretty = \case DoesNotSupportResolve fallback->@@ -69,7 +58,7 @@ mkCodeActionHandlerWithResolve recorder codeActionMethod codeResolveMethod = let newCodeActionMethod ideState pid params = do codeActionReturn <- codeActionMethod ideState pid params- caps <- lift getClientCapabilities+ caps <- lift pluginGetClientCapabilities case codeActionReturn of r@(InR Null) -> pure r (InL ls) | -- We don't need to do anything if the client supports@@ -83,7 +72,7 @@ <> mkResolveHandler SMethod_CodeActionResolve codeResolveMethod) where dropData :: CodeAction -> CodeAction dropData ca = ca & L.data_ .~ Nothing- resolveCodeAction :: Uri -> ideState -> PluginId -> (Command |? CodeAction) -> ExceptT PluginError (LspT Config IO) (Command |? CodeAction)+ resolveCodeAction :: Uri -> ideState -> PluginId -> (Command |? CodeAction) -> ExceptT PluginError (HandlerM Config) (Command |? CodeAction) resolveCodeAction _uri _ideState _plId c@(InL _) = pure c resolveCodeAction uri ideState pid (InR codeAction@CodeAction{_data_=Just value}) = do case A.fromJSON value of@@ -114,7 +103,7 @@ mkCodeActionWithResolveAndCommand recorder plId codeActionMethod codeResolveMethod = let newCodeActionMethod ideState pid params = do codeActionReturn <- codeActionMethod ideState pid params- caps <- lift getClientCapabilities+ caps <- lift pluginGetClientCapabilities case codeActionReturn of r@(InR Null) -> pure r (InL ls) | -- We don't need to do anything if the client supports@@ -144,25 +133,24 @@ codeAction & L.data_ .~ (A.toJSON .WithURI uri <$> data_) where data_ = codeAction ^? L.data_ . _Just executeResolveCmd :: ResolveFunction ideState a 'Method_CodeActionResolve -> CommandFunction ideState CodeAction- executeResolveCmd resolveProvider ideState ca@CodeAction{_data_=Just value} = do- ExceptT $ withIndefiniteProgress "Applying edits for code action..." Cancellable $ runExceptT $ do- case A.fromJSON value of- A.Error err -> throwError $ parseError (Just value) (T.pack err)- A.Success (WithURI uri innerValue) -> do- case A.fromJSON innerValue of- A.Error err -> throwError $ parseError (Just value) (T.pack err)- A.Success innerValueDecoded -> do- resolveResult <- resolveProvider ideState plId ca uri innerValueDecoded- case resolveResult of- ca2@CodeAction {_edit = Just wedits } | diffCodeActions ca ca2 == ["edit"] -> do- _ <- ExceptT $ Right <$> sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedits) handleWEditCallback- pure $ InR Null- ca2@CodeAction {_edit = Just _ } ->- throwError $ internalError $- "The resolve provider unexpectedly returned a code action with the following differing fields: "- <> (T.pack $ show $ diffCodeActions ca ca2)- _ -> throwError $ internalError "The resolve provider unexpectedly returned a result with no data field"- executeResolveCmd _ _ CodeAction{_data_= value} = throwError $ invalidParamsError ("The code action to resolve has an illegal data field: " <> (T.pack $ show value))+ executeResolveCmd resolveProvider ideState _token ca@CodeAction{_data_=Just value} = do+ case A.fromJSON value of+ A.Error err -> throwError $ parseError (Just value) (T.pack err)+ A.Success (WithURI uri innerValue) -> do+ case A.fromJSON innerValue of+ A.Error err -> throwError $ parseError (Just value) (T.pack err)+ A.Success innerValueDecoded -> do+ resolveResult <- resolveProvider ideState plId ca uri innerValueDecoded+ case resolveResult of+ ca2@CodeAction {_edit = Just wedits } | diffCodeActions ca ca2 == ["edit"] -> do+ _ <- ExceptT $ Right <$> pluginSendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedits) handleWEditCallback+ pure $ InR Null+ ca2@CodeAction {_edit = Just _ } ->+ throwError $ internalError $+ "The resolve provider unexpectedly returned a code action with the following differing fields: "+ <> (T.pack $ show $ diffCodeActions ca ca2)+ _ -> throwError $ internalError "The resolve provider unexpectedly returned a result with no data field"+ executeResolveCmd _ _ _ CodeAction{_data_= value} = throwError $ invalidParamsError ("The code action to resolve has an illegal data field: " <> (T.pack $ show value)) handleWEditCallback (Left err ) = do logWith recorder Warning (ApplyWorkspaceEditFailed err) pure ()@@ -198,7 +186,7 @@ supportsCodeActionResolve caps = caps ^? L.textDocument . _Just . L.codeAction . _Just . L.dataSupport . _Just == Just True && case caps ^? L.textDocument . _Just . L.codeAction . _Just . L.resolveSupport . _Just of- Just row -> "edit" `elem` row .! #properties+ Just ClientCodeActionResolveOptions{_properties} -> "edit" `elem` _properties _ -> False internalError :: T.Text -> PluginError@@ -211,6 +199,7 @@ parseError value errMsg = PluginInternalError ("Ide.Plugin.Resolve: Error parsing value:"<> (T.pack $ show value) <> " Error: "<> errMsg) {- Note [Code action resolve fallback to commands]+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ To make supporting code action resolve easy for plugins, we want to let them provide one implementation that can be used both when clients support resolve, and when they don't.
src/Ide/PluginUtils.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} @@ -20,7 +18,7 @@ getClientConfig, getPluginConfig, configForPlugin,- pluginEnabled,+ handlesRequest, extractTextInRange, fullRange, mkLspCommand,@@ -30,10 +28,13 @@ allLspCmdIds', installSigUsr1Handler, subRange,+ rangesOverlap, positionInRange, usePropertyLsp, -- * Escape unescape,+ -- * toAbsolute+ toAbsolute ) where @@ -52,6 +53,7 @@ import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Types import Language.LSP.Server+import System.FilePath ((</>)) import qualified Text.Megaparsec as P import qualified Text.Megaparsec.Char as P import qualified Text.Megaparsec.Char.Lexer as P@@ -236,7 +238,20 @@ extractTextInRange :: Range -> T.Text -> T.Text extractTextInRange (Range (Position sl sc) (Position el ec)) s = newS where- focusLines = take (fromIntegral $ el - sl + 1) $ drop (fromIntegral sl) $ T.lines s+ focusLines =+ T.lines s+ -- NOTE: Always append an empty line to the end to ensure there are+ -- sufficient lines to take from.+ --+ -- There is a situation that when the end position is placed at the line+ -- below the last line, if we simply do `drop` and then `take`, there+ -- will be `el - sl` lines left, not `el - sl + 1` lines. And then+ -- the last line of code will be emptied unexpectedly.+ --+ -- For details, see https://github.com/haskell/haskell-language-server/issues/3847+ & (++ [""])+ & drop (fromIntegral sl)+ & take (fromIntegral $ el - sl + 1) -- NOTE: We have to trim the last line first to handle the single-line case newS = focusLines@@ -263,6 +278,21 @@ subRange :: Range -> Range -> Bool subRange = isSubrangeOf ++-- | Check whether the two 'Range's overlap in any way.+--+-- >>> rangesOverlap (mkRange 1 0 1 4) (mkRange 1 2 1 5)+-- True+-- >>> rangesOverlap (mkRange 1 2 1 5) (mkRange 1 0 1 4)+-- True+-- >>> rangesOverlap (mkRange 1 0 1 6) (mkRange 1 2 1 4)+-- True+-- >>> rangesOverlap (mkRange 1 2 1 4) (mkRange 1 0 1 6)+-- True+rangesOverlap :: Range -> Range -> Bool+rangesOverlap r1 r2 =+ r1 ^. L.start <= r2 ^. L.end && r2 ^. L.start <= r1 ^. L.end+ -- --------------------------------------------------------------------- allLspCmdIds' :: T.Text -> IdePlugins ideState -> [T.Text]@@ -305,3 +335,12 @@ inside' = concatMap f inside pure $ "\"" <> inside' <> "\""++-- ---------------------------------------------------------------------++-- | toAbsolute+-- use `toAbsolute` to state our intention that we are actually make a path absolute+-- the first argument should be the root directory+-- the second argument should be the relative path+toAbsolute :: FilePath -> FilePath -> FilePath+toAbsolute = (</>)
src/Ide/Types.hs view
@@ -1,44 +1,37 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE BlockArguments #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MonadComprehensions #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedLabels #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE CUSKs #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MonadComprehensions #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-} module Ide.Types ( PluginDescriptor(..), defaultPluginDescriptor, defaultCabalPluginDescriptor , defaultPluginPriority+, describePlugin , IdeCommand(..) , IdeMethod(..) , IdeNotification(..) , IdePlugins(IdePlugins, ipMap) , DynFlagsModifications(..)-, Config(..), PluginConfig(..), CheckParents(..)-, ConfigDescriptor(..), defaultConfigDescriptor, configForPlugin, pluginEnabledConfig+, Config(..), PluginConfig(..), CheckParents(..), SessionLoadingPreferenceConfig(..)+, ConfigDescriptor(..), defaultConfigDescriptor, configForPlugin , CustomConfig(..), mkCustomConfig , FallbackCodeActionParams(..)-, FormattingType(..), FormattingMethod, FormattingHandler, mkFormattingHandlers+, FormattingType(..), FormattingMethod, FormattingHandler , HasTracing(..) , PluginCommand(..), CommandId(..), CommandFunction, mkLspCommand, mkLspCmdId , PluginId(..) , PluginHandler(..), mkPluginHandler+, HandlerM, runHandlerM, pluginGetClientCapabilities, pluginSendNotification, pluginSendRequest, pluginWithIndefiniteProgress , PluginHandlers(..) , PluginMethod(..) , PluginMethodHandler@@ -46,6 +39,7 @@ , PluginNotificationHandlers(..) , PluginRequestMethod(..) , getProcessID, getPid+, getVirtualFileFromVFS , installSigUsr1Handler , lookupCommandProvider , ResolveFunction@@ -66,12 +60,14 @@ import Control.Applicative ((<|>)) import Control.Arrow ((&&&))-import Control.Lens (_Just, (.~), (?~), (^.), (^?))+import Control.Lens (_Just, view, (.~), (?~), (^.),+ (^?)) import Control.Monad (void) import Control.Monad.Error.Class (MonadError (throwError))-import Control.Monad.Trans.Class (MonadTrans (lift))+import Control.Monad.IO.Class (MonadIO) import Control.Monad.Trans.Except (ExceptT, runExceptT) import Data.Aeson hiding (Null, defaultOptions)+import qualified Data.Aeson.Types as A import Data.Default import Data.Dependent.Map (DMap) import qualified Data.Dependent.Map as DMap@@ -94,18 +90,26 @@ import GHC (DynFlags) import GHC.Generics import Ide.Plugin.Error+import Ide.Plugin.HandleRequestTypes import Ide.Plugin.Properties import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types-import Language.LSP.Server (LspM, LspT, getVirtualFile)+import qualified Language.LSP.Protocol.Types as J+import Language.LSP.Server import Language.LSP.VFS import Numeric.Natural import OpenTelemetry.Eventlog import Options.Applicative (ParserInfo)-import System.FilePath+import Prettyprinter as PP import System.IO.Unsafe import Text.Regex.TDFA.Text ()+import UnliftIO (MonadUnliftIO)++#if !MIN_VERSION_base(4,20,0)+import Data.Foldable (foldl')+#endif+ -- --------------------------------------------------------------------- data IdePlugins ideState = IdePlugins_@@ -174,6 +178,7 @@ , formattingProvider :: !T.Text , cabalFormattingProvider :: !T.Text , maxCompletions :: !Int+ , sessionLoading :: !SessionLoadingPreferenceConfig , plugins :: !(Map.Map PluginId PluginConfig) } deriving (Show,Eq) @@ -182,7 +187,9 @@ object [ "checkParents" .= checkParents , "checkProject" .= checkProject , "formattingProvider" .= formattingProvider+ , "cabalFormattingProvider" .= cabalFormattingProvider , "maxCompletions" .= maxCompletions+ , "sessionLoading" .= sessionLoading , "plugin" .= Map.mapKeysMonotonic (\(PluginId p) -> p) plugins ] @@ -191,11 +198,12 @@ { checkParents = CheckOnSave , checkProject = True , formattingProvider = "ormolu"- -- , formattingProvider = "floskell" -- , formattingProvider = "stylish-haskell"- , cabalFormattingProvider = "cabal-fmt"+ , cabalFormattingProvider = "cabal-gild"+ -- , cabalFormattingProvider = "cabal-fmt" -- this string value needs to kept in sync with the value provided in HlsPlugins , maxCompletions = 40+ , sessionLoading = PreferSingleComponentLoading , plugins = mempty } @@ -208,6 +216,39 @@ deriving stock (Eq, Ord, Show, Generic) deriving anyclass (FromJSON, ToJSON) ++data SessionLoadingPreferenceConfig+ = PreferSingleComponentLoading+ -- ^ Always load only a singleComponent when a new component+ -- is discovered.+ | PreferMultiComponentLoading+ -- ^ Always prefer loading multiple components in the cradle+ -- at once. This might not be always possible, if the tool doesn't+ -- support multiple components loading.+ --+ -- The cradle can decide how to handle these situations, and whether+ -- to honour the preference at all.+ deriving stock (Eq, Ord, Show, Generic)++instance Pretty SessionLoadingPreferenceConfig where+ pretty PreferSingleComponentLoading = "Prefer Single Component Loading"+ pretty PreferMultiComponentLoading = "Prefer Multiple Components Loading"++instance ToJSON SessionLoadingPreferenceConfig where+ toJSON PreferSingleComponentLoading =+ String "singleComponent"+ toJSON PreferMultiComponentLoading =+ String "multipleComponents"++instance FromJSON SessionLoadingPreferenceConfig where+ parseJSON (String val) = case val of+ "singleComponent" -> pure PreferSingleComponentLoading+ "multipleComponents" -> pure PreferMultiComponentLoading+ _ -> A.prependFailure "parsing SessionLoadingPreferenceConfig failed, "+ (A.parseFail $ "Expected one of \"singleComponent\" or \"multipleComponents\" but got " <> T.unpack val )+ parseJSON o = A.prependFailure "parsing SessionLoadingPreferenceConfig failed, "+ (A.typeMismatch "String" o)+ -- | 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.@@ -218,13 +259,16 @@ , plcCallHierarchyOn :: !Bool , plcCodeActionsOn :: !Bool , plcCodeLensOn :: !Bool+ , plcInlayHintsOn :: !Bool , plcDiagnosticsOn :: !Bool , plcHoverOn :: !Bool , plcSymbolsOn :: !Bool+ , plcSignatureHelpOn :: !Bool , plcCompletionOn :: !Bool , plcRenameOn :: !Bool , plcSelectionRangeOn :: !Bool , plcFoldingRangeOn :: !Bool+ , plcSemanticTokensOn :: !Bool , plcConfig :: !Object } deriving (Show,Eq) @@ -234,30 +278,36 @@ , plcCallHierarchyOn = True , plcCodeActionsOn = True , plcCodeLensOn = True+ , plcInlayHintsOn = True , plcDiagnosticsOn = True , plcHoverOn = True , plcSymbolsOn = True+ , plcSignatureHelpOn = True , plcCompletionOn = True , plcRenameOn = True , plcSelectionRangeOn = True- , plcFoldingRangeOn = True+ , plcFoldingRangeOn = True+ , plcSemanticTokensOn = True , plcConfig = mempty } instance ToJSON PluginConfig where- toJSON (PluginConfig g ch ca cl d h s c rn sr fr cfg) = r+ toJSON (PluginConfig g ch ca ih cl d h s sh c rn sr fr st cfg) = r where r = object [ "globalOn" .= g , "callHierarchyOn" .= ch , "codeActionsOn" .= ca , "codeLensOn" .= cl+ , "inlayHintsOn" .= ih , "diagnosticsOn" .= d , "hoverOn" .= h , "symbolsOn" .= s+ , "signatureHelpOn" .= sh , "completionOn" .= c , "renameOn" .= rn , "selectionRangeOn" .= sr , "foldingRangeOn" .= fr+ , "semanticTokensOn" .= st , "config" .= cfg ] @@ -265,6 +315,7 @@ data PluginDescriptor (ideState :: Type) = PluginDescriptor { pluginId :: !PluginId+ , pluginDescription :: !T.Text -- ^ Unique identifier of the plugin. , pluginPriority :: Natural -- ^ Plugin handlers are called in priority order, higher priority first@@ -275,24 +326,21 @@ , pluginNotificationHandlers :: PluginNotificationHandlers ideState , pluginModifyDynflags :: DynFlagsModifications , pluginCli :: Maybe (ParserInfo (IdeCommand ideState))- , pluginFileType :: [T.Text]+ , pluginLanguageIds :: [J.LanguageKind] -- ^ File extension of the files the plugin is responsible for. -- The plugin is only allowed to handle files with these extensions. -- When writing handlers, etc. for this plugin it can be assumed that all handled files are of this type. -- The file extension must have a leading '.'. } --- | Check whether the given plugin descriptor is responsible for the file with the given path.--- Compares the file extension of the file at the given path with the file extension--- the plugin is responsible for.-pluginResponsible :: Uri -> PluginDescriptor c -> Bool-pluginResponsible uri pluginDesc- | Just fp <- mfp- , T.pack (takeExtension fp) `elem` pluginFileType pluginDesc = True- | otherwise = False- where- mfp = uriToFilePath uri+describePlugin :: PluginDescriptor c -> Doc ann+describePlugin p =+ let+ PluginId pid = pluginId p+ pdesc = pluginDescription p+ in pretty pid <> ":" <> nest 4 (PP.line <> pretty pdesc) + -- | An existential wrapper of 'Properties' data CustomConfig = forall r. CustomConfig (Properties r) @@ -333,26 +381,76 @@ defaultConfigDescriptor = ConfigDescriptor Data.Default.def False (mkCustomConfig emptyProperties) +-- | Lookup the current config for a plugin+configForPlugin :: Config -> PluginDescriptor c -> PluginConfig+configForPlugin config PluginDescriptor{..}+ = Map.findWithDefault (configInitialGenericConfig pluginConfigDescriptor) pluginId (plugins config)++-- | Checks that a specific plugin is globally enabled in order to respond to+-- requests+pluginEnabledGlobally :: PluginDescriptor c -> Config -> HandleRequestResult+pluginEnabledGlobally desc conf = if plcGlobalOn (configForPlugin conf desc)+ then HandlesRequest+ else DoesNotHandleRequest DisabledGlobally++-- | Checks that a specific feature for a given plugin is enabled in order+-- to respond to requests+pluginFeatureEnabled :: (PluginConfig -> Bool) -> PluginDescriptor c -> Config -> HandleRequestResult+pluginFeatureEnabled f desc conf = if f (configForPlugin conf desc)+ then HandlesRequest+ else DoesNotHandleRequest FeatureDisabled++-- |Determine whether this request should be routed to the plugin. Fails closed+-- if we can't determine which plugin it should be routed to.+pluginResolverResponsible :: L.HasData_ m (Maybe Value) => m -> PluginDescriptor c -> HandleRequestResult+pluginResolverResponsible+ (view L.data_ -> (Just (fromJSON -> (Success (PluginResolveData o@(PluginId ot) _ _)))))+ pluginDesc =+ if pluginId pluginDesc == o+ then HandlesRequest+ else DoesNotHandleRequest $ NotResolveOwner ot+-- If we can't determine who this request belongs to, then we don't want any plugin+-- to handle it.+pluginResolverResponsible _ _ = DoesNotHandleRequest $ NotResolveOwner "(unable to determine resolve owner)"++-- | Check whether the given plugin descriptor supports the file with+-- the given path. Compares the file extension from the msgParams with the+-- file extension the plugin is responsible for.+-- We are passing the msgParams here even though we only need the URI URI here.+-- If in the future we need to be able to provide only an URI it can be+-- separated again.+pluginSupportsFileType :: (L.HasTextDocument m doc, L.HasUri doc Uri) => VFS -> m -> PluginDescriptor c -> HandleRequestResult+pluginSupportsFileType (VFS vfs) msgParams pluginDesc =+ case languageKindM of+ Just languageKind | languageKind `elem` pluginLanguageIds pluginDesc -> HandlesRequest+ _ -> DoesNotHandleRequest $ DoesNotSupportFileType (maybe "(unable to determine file type)" (T.pack . show) languageKindM)+ where+ mVFE = getVirtualFileFromVFSIncludingClosed (VFS vfs) uri+ uri = toNormalizedUri $ msgParams ^. L.textDocument . L.uri+ languageKindM =+ case mVFE of+ Just x -> virtualFileEntryLanguageKind x+ _ -> Nothing+ -- | 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 (k :: MessageKind) (m :: Method ClientToServer k) where - -- | Parse the configuration to check if this plugin is enabled.- -- Perform sanity checks on the message to see whether the plugin is enabled- -- for this message in particular.- -- If a plugin is not enabled, its handlers, commands, etc. will not be- -- run for the given message.+ -- | Parse the configuration to check if this plugin is globally enabled, and+ -- if the feature which handles this method is enabled. Perform sanity checks+ -- on the message to see whether the plugin handles this message in particular.+ -- This class is only used to determine whether a plugin can handle a specific+ -- request. Commands and rules do not use this logic to determine whether or+ -- not they are run. --- -- Semantically, this method describes whether a plugin is enabled configuration wise- -- and is allowed to respond to the message. This might depend on the URI that is- -- associated to the Message Parameters. There are requests- -- with no associated URI that, consequentially, cannot inspect the URI. --- -- A common reason why a plugin might not be allowed to respond although it is enabled:+ -- A common reason why a plugin won't handle a request even though it is enabled: -- * The plugin cannot handle requests associated with the specific URI -- * Since the implementation of [cabal plugins](https://github.com/haskell/haskell-language-server/issues/2940) -- HLS knows plugins specific to Haskell and specific to [Cabal file descriptions](https://cabal.readthedocs.io/en/3.6/cabal-package.html)+ -- * The resolve request is not routed to that specific plugin. Each resolve+ -- request needs to be routed to only one plugin. -- -- Strictly speaking, we are conflating two concepts here: -- * Dynamically enabled (e.g. on a per-message basis)@@ -360,8 +458,10 @@ -- * Strictly speaking, this might also change dynamically -- -- But there is no use to split it up into two different methods for now.- pluginEnabled- :: SMethod m+ handlesRequest+ :: VFS+ -- ^ The virtual file system, contains the language kind of the file.+ -> SMethod m -- ^ Method type. -> MessageParams m -- ^ Whether a plugin is enabled might depend on the message parameters@@ -372,173 +472,206 @@ -> Config -- ^ Generic config description, expected to contain 'PluginConfig' configuration -- for this plugin- -> Bool+ -> HandleRequestResult -- ^ Is this plugin enabled and allowed to respond to the given request -- with the given parameters? - default pluginEnabled :: (L.HasTextDocument (MessageParams m) doc, L.HasUri doc Uri)- => SMethod m -> MessageParams m -> PluginDescriptor c -> Config -> Bool- pluginEnabled _ params desc conf = pluginResponsible uri desc && plcGlobalOn (configForPlugin conf desc)- where- uri = params ^. L.textDocument . L.uri---- ------------------------------------------------------------------------ Plugin Requests--- ---------------------------------------------------------------------+ default handlesRequest :: (L.HasTextDocument (MessageParams m) doc, L.HasUri doc Uri)+ => VFS -> SMethod m -> MessageParams m -> PluginDescriptor c -> Config -> HandleRequestResult+ handlesRequest vfs _ params desc conf =+ pluginEnabledGlobally desc conf <> pluginSupportsFileType vfs params desc -class PluginMethod Request m => PluginRequestMethod (m :: Method ClientToServer Request) where- -- | How to combine responses from different plugins.- --- -- For example, for Hover requests, we might have multiple producers of- -- Hover information. We do not want to decide which one to display to the user- -- but instead allow to define how to merge two hover request responses into one- -- glorious hover box.- --- -- However, as sometimes only one handler of a request can realistically exist- -- (such as TextDocumentFormatting), it is safe to just unconditionally report- -- back one arbitrary result (arbitrary since it should only be one anyway).- combineResponses- :: SMethod m- -> Config -- ^ IDE Configuration- -> ClientCapabilities- -> MessageParams m- -> NonEmpty (MessageResult m) -> MessageResult m+-- | Check if a plugin is enabled, if one of it's specific config's is enabled,+-- and if it supports the file+pluginEnabledWithFeature :: (L.HasTextDocument (MessageParams m) doc, L.HasUri doc Uri)+ => (PluginConfig -> Bool) -> VFS -> SMethod m -> MessageParams m+ -> PluginDescriptor c -> Config -> HandleRequestResult+pluginEnabledWithFeature feature vfs _ msgParams pluginDesc config =+ pluginEnabledGlobally pluginDesc config+ <> pluginFeatureEnabled feature pluginDesc config+ <> pluginSupportsFileType vfs msgParams pluginDesc - default combineResponses :: Semigroup (MessageResult m)- => SMethod m -> Config -> ClientCapabilities -> MessageParams m -> NonEmpty (MessageResult m) -> MessageResult m- combineResponses _method _config _caps _params = sconcat+-- | Check if a plugin is enabled, if one of it's specific configs is enabled,+-- and if it's the plugin responsible for a resolve request.+pluginEnabledResolve :: L.HasData_ s (Maybe Value) => (PluginConfig -> Bool) -> VFS -> p -> s -> PluginDescriptor c -> Config -> HandleRequestResult+pluginEnabledResolve feature _ _ msgParams pluginDesc config =+ pluginEnabledGlobally pluginDesc config+ <> pluginFeatureEnabled feature pluginDesc config+ <> pluginResolverResponsible msgParams pluginDesc instance PluginMethod Request Method_TextDocumentCodeAction where- pluginEnabled _ msgParams pluginDesc config =- pluginResponsible uri pluginDesc && pluginEnabledConfig plcCodeActionsOn (configForPlugin config pluginDesc)- where- uri = msgParams ^. L.textDocument . L.uri+ handlesRequest = pluginEnabledWithFeature plcCodeActionsOn instance PluginMethod Request Method_CodeActionResolve where -- See Note [Resolve in PluginHandlers]- pluginEnabled _ msgParams pluginDesc config =- pluginResolverResponsible (msgParams ^. L.data_) pluginDesc- && pluginEnabledConfig plcCodeActionsOn (configForPlugin config pluginDesc)+ handlesRequest = pluginEnabledResolve plcCodeActionsOn instance PluginMethod Request Method_TextDocumentDefinition where- pluginEnabled _ msgParams pluginDesc _ =- pluginResponsible uri pluginDesc- where- uri = msgParams ^. L.textDocument . L.uri+ handlesRequest vfs _ msgParams pluginDesc _ = pluginSupportsFileType vfs msgParams pluginDesc instance PluginMethod Request Method_TextDocumentTypeDefinition where- pluginEnabled _ msgParams pluginDesc _ =- pluginResponsible uri pluginDesc- where- uri = msgParams ^. L.textDocument . L.uri+ handlesRequest vfs _ msgParams pluginDesc _ = pluginSupportsFileType vfs msgParams pluginDesc +instance PluginMethod Request Method_TextDocumentImplementation where+ handlesRequest vfs _ msgParams pluginDesc _ = pluginSupportsFileType vfs msgParams pluginDesc+ instance PluginMethod Request Method_TextDocumentDocumentHighlight where- pluginEnabled _ msgParams pluginDesc _ =- pluginResponsible uri pluginDesc- where- uri = msgParams ^. L.textDocument . L.uri+ handlesRequest vfs _ msgParams pluginDesc _ = pluginSupportsFileType vfs msgParams pluginDesc instance PluginMethod Request Method_TextDocumentReferences where- pluginEnabled _ msgParams pluginDesc _ =- pluginResponsible uri pluginDesc- where- uri = msgParams ^. L.textDocument . L.uri+ handlesRequest vfs _ msgParams pluginDesc _ = pluginSupportsFileType vfs msgParams pluginDesc instance PluginMethod Request Method_WorkspaceSymbol where -- Unconditionally enabled, but should it really be?- pluginEnabled _ _ _ _ = True+ handlesRequest _ _ _ _ _ = HandlesRequest +instance PluginMethod Request Method_TextDocumentInlayHint where+ handlesRequest = pluginEnabledWithFeature plcInlayHintsOn++instance PluginMethod Request Method_InlayHintResolve where+ handlesRequest = pluginEnabledResolve plcInlayHintsOn+ instance PluginMethod Request Method_TextDocumentCodeLens where- pluginEnabled _ msgParams pluginDesc config = pluginResponsible uri pluginDesc- && pluginEnabledConfig plcCodeLensOn (configForPlugin config pluginDesc)- where- uri = msgParams ^. L.textDocument . L.uri+ handlesRequest = pluginEnabledWithFeature plcCodeLensOn instance PluginMethod Request Method_CodeLensResolve where -- See Note [Resolve in PluginHandlers]- pluginEnabled _ msgParams pluginDesc config =- pluginResolverResponsible (msgParams ^. L.data_) pluginDesc- && pluginEnabledConfig plcCodeActionsOn (configForPlugin config pluginDesc)+ handlesRequest = pluginEnabledResolve plcCodeLensOn instance PluginMethod Request Method_TextDocumentRename where- pluginEnabled _ msgParams pluginDesc config = pluginResponsible uri pluginDesc- && pluginEnabledConfig plcRenameOn (configForPlugin config pluginDesc)- where- uri = msgParams ^. L.textDocument . L.uri+ handlesRequest = pluginEnabledWithFeature plcRenameOn++instance PluginMethod Request Method_TextDocumentPrepareRename where+ handlesRequest = pluginEnabledWithFeature plcRenameOn+ instance PluginMethod Request Method_TextDocumentHover where- pluginEnabled _ msgParams pluginDesc config = pluginResponsible uri pluginDesc- && pluginEnabledConfig plcHoverOn (configForPlugin config pluginDesc)- where- uri = msgParams ^. L.textDocument . L.uri+ handlesRequest = pluginEnabledWithFeature plcHoverOn instance PluginMethod Request Method_TextDocumentDocumentSymbol where- pluginEnabled _ msgParams pluginDesc config = pluginResponsible uri pluginDesc- && pluginEnabledConfig plcSymbolsOn (configForPlugin config pluginDesc)- where- uri = msgParams ^. L.textDocument . L.uri+ handlesRequest = pluginEnabledWithFeature plcSymbolsOn +instance PluginMethod Request Method_TextDocumentSignatureHelp where+ handlesRequest = pluginEnabledWithFeature plcSignatureHelpOn+ instance PluginMethod Request Method_CompletionItemResolve where -- See Note [Resolve in PluginHandlers]- pluginEnabled _ msgParams pluginDesc config = pluginResolverResponsible (msgParams ^. L.data_) pluginDesc- && pluginEnabledConfig plcCompletionOn (configForPlugin config pluginDesc)+ handlesRequest = pluginEnabledResolve plcCompletionOn instance PluginMethod Request Method_TextDocumentCompletion where- pluginEnabled _ msgParams pluginDesc config = pluginResponsible uri pluginDesc- && pluginEnabledConfig plcCompletionOn (configForPlugin config pluginDesc)- where- uri = msgParams ^. L.textDocument . L.uri+ handlesRequest = pluginEnabledWithFeature plcCompletionOn instance PluginMethod Request Method_TextDocumentFormatting where- pluginEnabled SMethod_TextDocumentFormatting msgParams pluginDesc conf =- pluginResponsible uri pluginDesc- && (PluginId (formattingProvider conf) == pid || PluginId (cabalFormattingProvider conf) == pid)+ handlesRequest vfs _ msgParams pluginDesc conf =+ (if PluginId (formattingProvider conf) == pid+ || PluginId (cabalFormattingProvider conf) == pid+ then HandlesRequest+ else DoesNotHandleRequest (NotFormattingProvider (formattingProvider conf)) )+ <> pluginSupportsFileType vfs msgParams pluginDesc where- uri = msgParams ^. L.textDocument . L.uri pid = pluginId pluginDesc instance PluginMethod Request Method_TextDocumentRangeFormatting where- pluginEnabled _ msgParams pluginDesc conf = pluginResponsible uri pluginDesc- && (PluginId (formattingProvider conf) == pid || PluginId (cabalFormattingProvider conf) == pid)+ handlesRequest vfs _ msgParams pluginDesc conf =+ (if PluginId (formattingProvider conf) == pid+ || PluginId (cabalFormattingProvider conf) == pid+ then HandlesRequest+ else DoesNotHandleRequest (NotFormattingProvider (formattingProvider conf)))+ <> pluginSupportsFileType vfs msgParams pluginDesc where- uri = msgParams ^. L.textDocument . L.uri pid = pluginId pluginDesc +instance PluginMethod Request Method_TextDocumentSemanticTokensFull where+ handlesRequest = pluginEnabledWithFeature plcSemanticTokensOn++instance PluginMethod Request Method_TextDocumentSemanticTokensFullDelta where+ handlesRequest = pluginEnabledWithFeature plcSemanticTokensOn+ instance PluginMethod Request Method_TextDocumentPrepareCallHierarchy where- pluginEnabled _ msgParams pluginDesc conf = pluginResponsible uri pluginDesc- && pluginEnabledConfig plcCallHierarchyOn (configForPlugin conf pluginDesc)- where- uri = msgParams ^. L.textDocument . L.uri+ handlesRequest = pluginEnabledWithFeature plcCallHierarchyOn instance PluginMethod Request Method_TextDocumentSelectionRange where- pluginEnabled _ msgParams pluginDesc conf = pluginResponsible uri pluginDesc- && pluginEnabledConfig plcSelectionRangeOn (configForPlugin conf pluginDesc)- where- uri = msgParams ^. L.textDocument . L.uri+ handlesRequest = pluginEnabledWithFeature plcSelectionRangeOn instance PluginMethod Request Method_TextDocumentFoldingRange where- pluginEnabled _ msgParams pluginDesc conf = pluginResponsible uri pluginDesc- && pluginEnabledConfig plcFoldingRangeOn (configForPlugin conf pluginDesc)- where- uri = msgParams ^. L.textDocument . L.uri+ handlesRequest = pluginEnabledWithFeature plcFoldingRangeOn instance PluginMethod Request Method_CallHierarchyIncomingCalls where -- This method has no URI parameter, thus no call to 'pluginResponsible'- pluginEnabled _ _ pluginDesc conf = pluginEnabledConfig plcCallHierarchyOn (configForPlugin conf pluginDesc)+ handlesRequest _ _ _ pluginDesc conf =+ pluginEnabledGlobally pluginDesc conf+ <> pluginFeatureEnabled plcCallHierarchyOn pluginDesc conf instance PluginMethod Request Method_CallHierarchyOutgoingCalls where -- This method has no URI parameter, thus no call to 'pluginResponsible'- pluginEnabled _ _ pluginDesc conf = pluginEnabledConfig plcCallHierarchyOn (configForPlugin conf pluginDesc)+ handlesRequest _ _ _ pluginDesc conf =+ pluginEnabledGlobally pluginDesc conf+ <> pluginFeatureEnabled plcCallHierarchyOn pluginDesc conf instance PluginMethod Request Method_WorkspaceExecuteCommand where- pluginEnabled _ _ _ _= True+ handlesRequest _ _ _ _ _ = HandlesRequest instance PluginMethod Request (Method_CustomMethod m) where- pluginEnabled _ _ _ _ = True+ handlesRequest _ _ _ _ _ = HandlesRequest +-- Plugin Notifications++instance PluginMethod Notification Method_TextDocumentDidOpen where++instance PluginMethod Notification Method_TextDocumentDidChange where++instance PluginMethod Notification Method_TextDocumentDidSave where++instance PluginMethod Notification Method_TextDocumentDidClose where++instance PluginMethod Notification Method_WorkspaceDidChangeWatchedFiles where+ -- This method has no URI parameter, thus no call to 'pluginResponsible'.+ handlesRequest _ _ _ desc conf = pluginEnabledGlobally desc conf++instance PluginMethod Notification Method_WorkspaceDidChangeWorkspaceFolders where+ -- This method has no URI parameter, thus no call to 'pluginResponsible'.+ handlesRequest _ _ _ desc conf = pluginEnabledGlobally desc conf++instance PluginMethod Notification Method_WorkspaceDidChangeConfiguration where+ -- This method has no URI parameter, thus no call to 'pluginResponsible'.+ handlesRequest _ _ _ desc conf = pluginEnabledGlobally desc conf++instance PluginMethod Notification Method_Initialized where+ -- This method has no URI parameter, thus no call to 'pluginResponsible'.+ handlesRequest _ _ _ desc conf = pluginEnabledGlobally desc conf+++-- ---------------------------------------------------------------------+-- Plugin Requests+-- ---------------------------------------------------------------------++class PluginMethod Request m => PluginRequestMethod (m :: Method ClientToServer Request) where+ -- | How to combine responses from different plugins.+ --+ -- For example, for Hover requests, we might have multiple producers of+ -- Hover information. We do not want to decide which one to display to the user+ -- but instead allow to define how to merge two hover request responses into one+ -- glorious hover box.+ --+ -- However, as sometimes only one handler of a request can realistically exist+ -- (such as TextDocumentFormatting), it is safe to just unconditionally report+ -- back one arbitrary result (arbitrary since it should only be one anyway).+ combineResponses+ :: SMethod m+ -> Config -- ^ IDE Configuration+ -> ClientCapabilities+ -> MessageParams m+ -> NonEmpty (MessageResult m) -> MessageResult m++ default combineResponses :: Semigroup (MessageResult m)+ => SMethod m -> Config -> ClientCapabilities -> MessageParams m -> NonEmpty (MessageResult m) -> MessageResult m+ combineResponses _method _config _caps _params = sconcat+++ --- instance PluginRequestMethod Method_TextDocumentCodeAction where combineResponses _method _config (ClientCapabilities _ textDocCaps _ _ _ _) (CodeActionParams _ _ _ _ context) resps =- InL $ fmap compat $ filter wasRequested $ concat $ mapMaybe nullToMaybe $ toList resps+ InL $ fmap compat $ concatMap (filter wasRequested) $ mapMaybe nullToMaybe $ toList resps where compat :: (Command |? CodeAction) -> (Command |? CodeAction) compat x@(InL _) = x@@ -560,7 +693,7 @@ -- should check whether the requested kind is a *prefix* of the action kind. -- That means, for example, we will return actions with kinds `quickfix.import` and -- `quickfix.somethingElse` if the requested kind is `quickfix`.- , Just caKind <- ca ^. L.kind = any (\k -> k `codeActionKindSubsumes` caKind) allowed+ , Just caKind <- ca ^. L.kind = any (`codeActionKindSubsumes` caKind) allowed | otherwise = False instance PluginRequestMethod Method_CodeActionResolve where@@ -569,11 +702,20 @@ combineResponses _ _ _ _ (x :| _) = x instance PluginRequestMethod Method_TextDocumentDefinition where- combineResponses _ _ _ _ (x :| _) = x+ combineResponses _ _ caps _ (x :| xs)+ | Just (Just True) <- caps ^? (L.textDocument . _Just . L.definition . _Just . L.linkSupport) = foldl' mergeDefinitions x xs+ | otherwise = downgradeLinks $ foldl' mergeDefinitions x xs instance PluginRequestMethod Method_TextDocumentTypeDefinition where- combineResponses _ _ _ _ (x :| _) = x+ combineResponses _ _ caps _ (x :| xs)+ | Just (Just True) <- caps ^? (L.textDocument . _Just . L.typeDefinition . _Just . L.linkSupport) = foldl' mergeDefinitions x xs+ | otherwise = downgradeLinks $ foldl' mergeDefinitions x xs +instance PluginRequestMethod Method_TextDocumentImplementation where+ combineResponses _ _ caps _ (x :| xs)+ | Just (Just True) <- caps ^? (L.textDocument . _Just . L.implementation . _Just . L.linkSupport) = foldl' mergeDefinitions x xs+ | otherwise = downgradeLinks $ foldl' mergeDefinitions x xs+ instance PluginRequestMethod Method_TextDocumentDocumentHighlight where instance PluginRequestMethod Method_TextDocumentReferences where@@ -592,8 +734,12 @@ instance PluginRequestMethod Method_TextDocumentRename where +instance PluginRequestMethod Method_TextDocumentPrepareRename where+ -- TODO more intelligent combining?+ combineResponses _ _ _ _ (x :| _) = x+ instance PluginRequestMethod Method_TextDocumentHover where- combineResponses _ _ _ _ (mapMaybe nullToMaybe . toList -> hs :: [Hover]) =+ combineResponses _ _ _ _ (mapMaybe nullToMaybe . toList -> (hs :: [Hover])) = if null hs then InR Null else InL $ Hover (InL mcontent) r@@ -630,6 +776,9 @@ si = SymbolInformation name' (ds ^. L.kind) Nothing parent (ds ^. L.deprecated) loc in [si] <> children' +instance PluginRequestMethod Method_TextDocumentSignatureHelp where+ combineResponses _ _ _ _ (x :| _) = x+ instance PluginRequestMethod Method_CompletionItemResolve where -- A resolve request should only have one response. -- See Note [Resolve in PluginHandlers]@@ -686,6 +835,15 @@ instance PluginRequestMethod (Method_CustomMethod m) where combineResponses _ _ _ _ (x :| _) = x +instance PluginRequestMethod Method_TextDocumentSemanticTokensFull where+ combineResponses _ _ _ _ (x :| _) = x++instance PluginRequestMethod Method_TextDocumentSemanticTokensFullDelta where+ combineResponses _ _ _ _ (x :| _) = x++instance PluginRequestMethod Method_TextDocumentInlayHint where+ combineResponses _ _ _ _ x = sconcat x+ takeLefts :: [a |? b] -> [a] takeLefts = mapMaybe (\x -> [res | (InL res) <- Just x]) @@ -693,6 +851,45 @@ nullToMaybe' (InL x) = Just $ InL x nullToMaybe' (InR (InL x)) = Just $ InR x nullToMaybe' (InR (InR _)) = Nothing++type Definitions = (Definition |? ([DefinitionLink] |? Null))++-- | Merges two definition responses (TextDocumentDefinition | TextDocumentTypeDefinition)+-- into one preserving all locations and their order (including order of the responses).+-- Upgrades Location(s) into LocationLink(s) when one of the responses is LocationLink(s). With following fields:+-- * LocationLink.originSelectionRange = Nothing+-- * LocationLink.targetUri = Location.Uri+-- * LocationLink.targetRange = Location.Range+-- * LocationLink.targetSelectionRange = Location.Range+-- Ignores Null responses.+mergeDefinitions :: Definitions -> Definitions -> Definitions+mergeDefinitions definitions1 definitions2 = case (definitions1, definitions2) of+ (InR (InR Null), def2) -> def2+ (def1, InR (InR Null)) -> def1+ (InL def1, InL def2) -> InL $ mergeDefs def1 def2+ (InL def1, InR (InL links)) -> InR $ InL (defToLinks def1 ++ links)+ (InR (InL links), InL def2) -> InR $ InL (links ++ defToLinks def2)+ (InR (InL links1), InR (InL links2)) -> InR $ InL (links1 ++ links2)+ where+ defToLinks :: Definition -> [DefinitionLink]+ defToLinks (Definition (InL location)) = [locationToDefinitionLink location]+ defToLinks (Definition (InR locations)) = map locationToDefinitionLink locations++ locationToDefinitionLink :: Location -> DefinitionLink+ locationToDefinitionLink Location{_uri, _range} = DefinitionLink LocationLink{_originSelectionRange = Nothing, _targetUri = _uri, _targetRange = _range, _targetSelectionRange = _range}++ mergeDefs :: Definition -> Definition -> Definition+ mergeDefs (Definition (InL loc1)) (Definition (InL loc2)) = Definition $ InR [loc1, loc2]+ mergeDefs (Definition (InR locs1)) (Definition (InL loc2)) = Definition $ InR (locs1 ++ [loc2])+ mergeDefs (Definition (InL loc1)) (Definition (InR locs2)) = Definition $ InR (loc1 : locs2)+ mergeDefs (Definition (InR locs1)) (Definition (InR locs2)) = Definition $ InR (locs1 ++ locs2)++downgradeLinks :: Definitions -> Definitions+downgradeLinks (InR (InL links)) = InL . Definition . InR . map linkToLocation $ links+ where+ linkToLocation :: DefinitionLink -> Location+ linkToLocation (DefinitionLink LocationLink{_targetUri, _targetRange}) = Location {_uri = _targetUri, _range = _targetRange}+downgradeLinks defs = defs -- --------------------------------------------------------------------- -- Plugin Notifications -- ---------------------------------------------------------------------@@ -702,31 +899,6 @@ class PluginMethod Notification m => PluginNotificationMethod (m :: Method ClientToServer Notification) where -instance PluginMethod Notification Method_TextDocumentDidOpen where--instance PluginMethod Notification Method_TextDocumentDidChange where--instance PluginMethod Notification Method_TextDocumentDidSave where--instance PluginMethod Notification Method_TextDocumentDidClose where--instance PluginMethod Notification Method_WorkspaceDidChangeWatchedFiles where- -- This method has no URI parameter, thus no call to 'pluginResponsible'.- pluginEnabled _ _ desc conf = plcGlobalOn $ configForPlugin conf desc--instance PluginMethod Notification Method_WorkspaceDidChangeWorkspaceFolders where- -- This method has no URI parameter, thus no call to 'pluginResponsible'.- pluginEnabled _ _ desc conf = plcGlobalOn $ configForPlugin conf desc--instance PluginMethod Notification Method_WorkspaceDidChangeConfiguration where- -- This method has no URI parameter, thus no call to 'pluginResponsible'.- pluginEnabled _ _ desc conf = plcGlobalOn $ configForPlugin conf desc--instance PluginMethod Notification Method_Initialized where- -- This method has no URI parameter, thus no call to 'pluginResponsible'.- pluginEnabled _ _ desc conf = plcGlobalOn $ configForPlugin conf desc-- instance PluginNotificationMethod Method_TextDocumentDidOpen where instance PluginNotificationMethod Method_TextDocumentDidChange where@@ -759,9 +931,43 @@ instance GCompare IdeNotification where gcompare (IdeNotification a) (IdeNotification b) = gcompare a b +-- | Restricted version of 'LspM' specific to plugins.+--+-- We use this monad for running plugins instead of 'LspM', since there are+-- parts of the LSP server state which plugins should not access directly, but+-- instead only via the build system.+newtype HandlerM config a = HandlerM { _runHandlerM :: LspM config a }+ deriving newtype (Applicative, Functor, Monad, MonadIO, MonadUnliftIO)++runHandlerM :: HandlerM config a -> LspM config a+runHandlerM = _runHandlerM++-- | Wrapper of 'getClientCapabilities' for HandlerM+pluginGetClientCapabilities :: HandlerM config ClientCapabilities+pluginGetClientCapabilities = HandlerM getClientCapabilities++-- | Wrapper of 'sendNotification for HandlerM+--+-- TODO: Return notification in result instead of calling `sendNotification` directly+pluginSendNotification :: forall (m :: Method ServerToClient Notification) config. SServerMethod m -> MessageParams m -> HandlerM config ()+pluginSendNotification smethod params = HandlerM $ sendNotification smethod params++-- | Wrapper of 'sendRequest' for HandlerM+--+-- TODO: Return request in result instead of calling `sendRequest` directly+pluginSendRequest :: forall (m :: Method ServerToClient Request) config. SServerMethod m -> MessageParams m -> (Either (TResponseError m) (MessageResult m) -> HandlerM config ()) -> HandlerM config (LspId m)+pluginSendRequest smethod params action = HandlerM $ sendRequest smethod params (runHandlerM . action)++-- | Wrapper of 'withIndefiniteProgress' for HandlerM+pluginWithIndefiniteProgress :: T.Text -> Maybe ProgressToken -> ProgressCancellable -> ((T.Text -> HandlerM config ()) -> HandlerM config a) -> HandlerM config a+pluginWithIndefiniteProgress title progressToken cancellable updateAction =+ HandlerM $+ withIndefiniteProgress title progressToken cancellable $ \putUpdate ->+ runHandlerM $ updateAction (HandlerM . putUpdate)+ -- | Combine handlers for the newtype PluginHandler a (m :: Method ClientToServer Request)- = PluginHandler (PluginId -> a -> MessageParams m -> LspM Config (NonEmpty (Either PluginError (MessageResult m))))+ = PluginHandler (PluginId -> a -> MessageParams m -> HandlerM Config (NonEmpty (Either PluginError (MessageResult m)))) newtype PluginNotificationHandler a (m :: Method ClientToServer Notification) = PluginNotificationHandler (PluginId -> a -> VFS -> MessageParams m -> LspM Config ())@@ -786,7 +992,7 @@ instance Monoid (PluginNotificationHandlers a) where mempty = PluginNotificationHandlers mempty -type PluginMethodHandler a m = a -> PluginId -> MessageParams m -> ExceptT PluginError (LspM Config) (MessageResult m)+type PluginMethodHandler a m = a -> PluginId -> MessageParams m -> ExceptT PluginError (HandlerM Config) (MessageResult m) type PluginNotificationMethodHandler a m = a -> VFS -> PluginId -> MessageParams m -> LspM Config () @@ -799,7 +1005,7 @@ -> PluginHandlers ideState mkPluginHandler m f = PluginHandlers $ DMap.singleton (IdeMethod m) (PluginHandler (f' m)) where- f' :: SMethod m -> PluginId -> ideState -> MessageParams m -> LspT Config IO (NonEmpty (Either PluginError (MessageResult m)))+ f' :: SMethod m -> PluginId -> ideState -> MessageParams m -> HandlerM Config (NonEmpty (Either PluginError (MessageResult m))) -- We need to have separate functions for each method that supports resolve, so far we only support CodeActions -- CodeLens, and Completion methods. f' SMethod_TextDocumentCodeAction pid ide params@CodeActionParams{_textDocument=TextDocumentIdentifier {_uri}} =@@ -850,10 +1056,11 @@ -- -- and handlers will be enabled for files with the appropriate file -- extensions.-defaultPluginDescriptor :: PluginId -> PluginDescriptor ideState-defaultPluginDescriptor plId =+defaultPluginDescriptor :: PluginId -> T.Text -> PluginDescriptor ideState+defaultPluginDescriptor plId desc = PluginDescriptor plId+ desc defaultPluginPriority mempty mempty@@ -862,7 +1069,7 @@ mempty mempty Nothing- [".hs", ".lhs", ".hs-boot"]+ [J.LanguageKind_Haskell, J.LanguageKind_Custom "literate haskell"] -- | Set up a plugin descriptor, initialized with default values. -- This plugin descriptor is prepared for @.cabal@ files and as such,@@ -870,10 +1077,11 @@ -- -- Handles files with the following extensions: -- * @.cabal@-defaultCabalPluginDescriptor :: PluginId -> PluginDescriptor ideState-defaultCabalPluginDescriptor plId =+defaultCabalPluginDescriptor :: PluginId -> T.Text -> PluginDescriptor ideState+defaultCabalPluginDescriptor plId desc = PluginDescriptor plId+ desc defaultPluginPriority mempty mempty@@ -882,7 +1090,7 @@ mempty mempty Nothing- [".cabal"]+ [J.LanguageKind_Custom "cabal"] newtype CommandId = CommandId T.Text deriving (Show, Read, Eq, Ord)@@ -899,8 +1107,9 @@ type CommandFunction ideState a = ideState+ -> Maybe ProgressToken -> a- -> ExceptT PluginError (LspM Config) (Value |? Null)+ -> ExceptT PluginError (HandlerM Config) (Value |? Null) -- --------------------------------------------------------------------- @@ -910,7 +1119,7 @@ -> MessageParams m -> Uri -> a- -> ExceptT PluginError (LspM Config) (MessageResult m)+ -> ExceptT PluginError (HandlerM Config) (MessageResult m) -- | Make a handler for resolve methods. In here we take your provided ResolveFunction -- and turn it into a PluginHandlers. See Note [Resolve in PluginHandlers]@@ -921,7 +1130,7 @@ -> PluginHandlers ideState mkResolveHandler m f = mkPluginHandler m $ \ideState plId params -> do case fromJSON <$> (params ^. L.data_) of- (Just (Success (PluginResolveData owner uri value) )) -> do+ (Just (Success (PluginResolveData owner@(PluginId ownerName) uri value) )) -> do if owner == plId then case fromJSON value of@@ -931,7 +1140,8 @@ Error msg -> -- We are assuming that if we can't decode the data, that this -- request belongs to another resolve handler for this plugin.- throwError (PluginRequestRefused (T.pack ("Unable to decode payload for handler, assuming that it's for a different handler" <> msg)))+ throwError (PluginRequestRefused+ (NotResolveOwner (ownerName <> ": error decoding payload:" <> T.pack msg))) -- If we are getting an owner that isn't us, this means that there is an -- error, as we filter these our in `pluginEnabled` else throwError $ PluginInternalError invalidRequest@@ -942,7 +1152,7 @@ -- as this is filtered out in `pluginEnabled` _ -> throwError $ PluginInternalError invalidRequest where invalidRequest = "The resolve request incorrectly got routed to the wrong resolve handler!"- parseError value err = "Unable to decode: " <> (T.pack $ show value) <> ". Error: " <> (T.pack $ show err)+ parseError value err = "Unable to decode: " <> T.pack (show value) <> ". Error: " <> T.pack (show err) wrapResolveData :: L.HasData_ a (Maybe Value) => PluginId -> Uri -> a -> a wrapResolveData pid uri hasData =@@ -967,16 +1177,7 @@ instance IsString PluginId where fromString = PluginId . T.pack --- | Lookup the current config for a plugin-configForPlugin :: Config -> PluginDescriptor c -> PluginConfig-configForPlugin config PluginDescriptor{..}- = Map.findWithDefault (configInitialGenericConfig pluginConfigDescriptor) pluginId (plugins config) --- | Checks that a given plugin is both enabled and the specific feature is--- enabled-pluginEnabledConfig :: (PluginConfig -> Bool) -> PluginConfig -> Bool-pluginEnabledConfig f pluginConfig = plcGlobalOn pluginConfig && f pluginConfig- -- --------------------------------------------------------------------- -- | Format the given Text as a whole or only a @Range@ of it.@@ -995,37 +1196,15 @@ type FormattingHandler a = a+ -> Maybe ProgressToken -> FormattingType -> T.Text -> NormalizedFilePath -> FormattingOptions- -> ExceptT PluginError (LspM Config) ([TextEdit] |? Null)--mkFormattingHandlers :: forall a. FormattingHandler a -> PluginHandlers a-mkFormattingHandlers f = mkPluginHandler SMethod_TextDocumentFormatting ( provider SMethod_TextDocumentFormatting)- <> mkPluginHandler SMethod_TextDocumentRangeFormatting (provider SMethod_TextDocumentRangeFormatting)- where- provider :: forall m. FormattingMethod m => SMethod m -> PluginMethodHandler a m- provider m ide _pid params- | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = do- mf <- lift $ getVirtualFile $ toNormalizedUri uri- case mf of- Just vf -> do- let typ = case m of- SMethod_TextDocumentFormatting -> FormatText- SMethod_TextDocumentRangeFormatting -> FormatRange (params ^. L.range)- _ -> Prelude.error "mkFormattingHandlers: impossible"- f ide typ (virtualFileText vf) nfp opts- Nothing -> throwError $ PluginInvalidParams $ T.pack $ "Formatter plugin: could not get file contents for " ++ show uri-- | otherwise = throwError $ PluginInvalidParams $ T.pack $ "Formatter plugin: uriToFilePath failed for: " ++ show uri- where- uri = params ^. L.textDocument . L.uri- opts = params ^. L.options+ -> ExceptT PluginError (HandlerM Config) ([TextEdit] |? Null) -- --------------------------------------------------------------------- - data FallbackCodeActionParams = FallbackCodeActionParams { fallbackWorkspaceEdit :: Maybe WorkspaceEdit@@ -1087,6 +1266,20 @@ getPid :: IO T.Text getPid = T.pack . show <$> getProcessID +getVirtualFileFromVFS :: VFS -> NormalizedUri -> Maybe VirtualFile+getVirtualFileFromVFS (VFS vfs) uri =+ case Map.lookup uri vfs of+ Just (Open x) -> Just x+ Just (Closed _) -> Nothing+ Nothing -> Nothing++getVirtualFileFromVFSIncludingClosed :: VFS -> NormalizedUri -> Maybe VirtualFileEntry+getVirtualFileFromVFSIncludingClosed (VFS vfs) uri =+ case Map.lookup uri vfs of+ Just x -> Just x+ Nothing -> Nothing++ getProcessID :: IO Int installSigUsr1Handler :: IO () -> IO () @@ -1100,15 +1293,8 @@ installSigUsr1Handler h = void $ installHandler sigUSR1 (Catch h) Nothing #endif --- |Determine whether this request should be routed to the plugin. Fails closed--- if we can't determine which plugin it should be routed to.-pluginResolverResponsible :: Maybe Value -> PluginDescriptor c -> Bool-pluginResolverResponsible (Just (fromJSON -> (Success (PluginResolveData o _ _)))) pluginDesc =- pluginId pluginDesc == o--- We want to fail closed-pluginResolverResponsible _ _ = False- {- Note [Resolve in PluginHandlers]+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Resolve methods have a few guarantees that need to be made by HLS, specifically they need to only be called once, as neither their errors nor their responses can be easily combined. Whereas commands, which similarly have
test/Ide/PluginUtilsTest.hs view
@@ -1,27 +1,41 @@+{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -Wno-orphans #-} module Ide.PluginUtilsTest ( tests ) where -import Data.Char (isPrint)+import qualified Data.Aeson as A+import qualified Data.Aeson.Types as A+import Data.ByteString.Lazy (ByteString)+import Data.Function ((&)) import qualified Data.Set as Set import qualified Data.Text as T+import Ide.Plugin.Properties (KeyNamePath (..),+ definePropertiesProperty,+ defineStringProperty,+ emptyProperties, toDefaultJSON,+ toVSCodeExtensionSchema,+ usePropertyByPath,+ usePropertyByPathEither) import qualified Ide.Plugin.RangeMap as RangeMap-import Ide.PluginUtils (positionInRange, unescape)+import Ide.PluginUtils (extractTextInRange, unescape) import Language.LSP.Protocol.Types (Position (..), Range (Range), UInt, isSubrangeOf) import Test.Tasty+import Test.Tasty.Golden (goldenVsStringDiff) import Test.Tasty.HUnit import Test.Tasty.QuickCheck tests :: TestTree tests = testGroup "PluginUtils" [ unescapeTest+ , extractTextInRangeTest , localOption (QuickCheckMaxSize 10000) $ testProperty "RangeMap-List filtering identical" $ prop_rangemapListEq @Int+ , propertyTest ] unescapeTest :: TestTree@@ -42,6 +56,57 @@ unescape "\"\\n\\t\"" @?= "\"\\n\\t\"" ] +extractTextInRangeTest :: TestTree+extractTextInRangeTest = testGroup "extractTextInRange"+ [ testCase "inline range" $+ extractTextInRange+ ( Range (Position 0 3) (Position 3 5) )+ src+ @?= T.intercalate "\n"+ [ "ule Main where"+ , ""+ , "main :: IO ()"+ , "main "+ ]+ , testCase "inline range with empty content" $+ extractTextInRange+ ( Range (Position 0 0) (Position 0 1) )+ emptySrc+ @?= ""+ , testCase "multiline range with empty content" $+ extractTextInRange+ ( Range (Position 0 0) (Position 1 0) )+ emptySrc+ @?= "\n"+ , testCase "multiline range" $+ extractTextInRange+ ( Range (Position 1 0) (Position 4 0) )+ src+ @?= T.unlines+ [ ""+ , "main :: IO ()"+ , "main = do"+ ]+ , testCase "multiline range with end pos at the line below the last line" $+ extractTextInRange+ ( Range (Position 2 0) (Position 5 0) )+ src+ @?= T.unlines+ [ "main :: IO ()"+ , "main = do"+ , " putStrLn \"hello, world\""+ ]+ ]+ where+ src = T.unlines+ [ "module Main where"+ , ""+ , "main :: IO ()"+ , "main = do"+ , " putStrLn \"hello, world\""+ ]+ emptySrc = "\n"+ genRange :: Gen Range genRange = oneof [ genRangeInline, genRangeMultiline ] @@ -53,7 +118,7 @@ pure $ Range x1 x2 where genRangeLength :: Gen UInt- genRangeLength = fromInteger <$> chooseInteger (5, 50)+ genRangeLength = uInt (5, 50) genRangeMultiline :: Gen Range genRangeMultiline = do@@ -66,17 +131,20 @@ pure $ Range x1 x2 where genSecond :: Gen UInt- genSecond = fromInteger <$> chooseInteger (0, 10)+ genSecond = uInt (0, 10) genPosition :: Gen Position genPosition = Position- <$> (fromInteger <$> chooseInteger (0, 1000))- <*> (fromInteger <$> chooseInteger (0, 150))+ <$> uInt (0, 1000)+ <*> uInt (0, 150) +uInt :: (Integer, Integer) -> Gen UInt+uInt (a, b) = fromInteger <$> chooseInteger (a, b)+ instance Arbitrary Range where arbitrary = genRange -prop_rangemapListEq :: (Show a, Eq a, Ord a) => Range -> [(Range, a)] -> Property+prop_rangemapListEq :: (Show a, Ord a) => Range -> [(Range, a)] -> Property prop_rangemapListEq r xs = let filteredList = (map snd . filter (isSubrangeOf r . fst)) xs filteredRangeMap = RangeMap.filterByRange r (RangeMap.fromList' xs)@@ -84,3 +152,54 @@ cover 5 (length filteredList == 1) "1 match" $ cover 2 (length filteredList > 1) ">1 matches" $ Set.fromList filteredList === Set.fromList filteredRangeMap+++gitDiff :: FilePath -> FilePath -> [String]+gitDiff fRef fNew = ["git", "-c", "core.fileMode=false", "diff", "-w", "--no-index", "--text", "--exit-code", fRef, fNew]++goldenGitDiff :: TestName -> FilePath -> IO ByteString -> TestTree+goldenGitDiff name = goldenVsStringDiff name gitDiff++testDir :: FilePath+testDir = "test/testdata/Property"++propertyTest :: TestTree+propertyTest = testGroup "property api tests" [+ goldenGitDiff "property toVSCodeExtensionSchema" (testDir <> "/NestedPropertyVscode.json") (return $ A.encode $ A.object $ toVSCodeExtensionSchema "top." nestedPropertiesExample)+ , goldenGitDiff "property toDefaultJSON" (testDir <> "/NestedPropertyDefault.json") (return $ A.encode $ A.object $ toDefaultJSON nestedPropertiesExample)+ , testCase "parsePropertyPath single key path" $ do+ let obj = A.object (toDefaultJSON nestedPropertiesExample)+ let key1 = A.parseEither (A.withObject "test parsePropertyPath" $ \o -> do+ let key1 = usePropertyByPathEither examplePath1 nestedPropertiesExample o+ return key1) obj+ key1 @?= Right (Right "baz")+ , testCase "parsePropertyPath two key path" $ do+ let obj = A.object (toDefaultJSON nestedPropertiesExample)+ let key1 = A.parseEither (A.withObject "test parsePropertyPath" $ \o -> do+ let key1 = usePropertyByPathEither examplePath2 nestedPropertiesExample o+ return key1) obj+ key1 @?= Right (Right "foo")+ , testCase "parsePropertyPath two key path default" $ do+ let obj = A.object []+ let key1 = A.parseEither (A.withObject "test parsePropertyPath" $ \o -> do+ let key1 = usePropertyByPath examplePath2 nestedPropertiesExample o+ return key1) obj+ key1 @?= Right "foo"+ , testCase "parsePropertyPath two key path not default" $ do+ let obj = A.object (toDefaultJSON nestedPropertiesExample2)+ let key1 = A.parseEither (A.withObject "test parsePropertyPath" $ \o -> do+ let key1 = usePropertyByPathEither examplePath2 nestedPropertiesExample o+ return key1) obj+ key1 @?= Right (Right "xxx")+ ]+ where+ nestedPropertiesExample = emptyProperties+ & definePropertiesProperty #parent "parent" (emptyProperties & defineStringProperty #foo "foo" "foo" & defineStringProperty #boo "boo" "boo")+ & defineStringProperty #baz "baz" "baz"++ nestedPropertiesExample2 = emptyProperties+ & definePropertiesProperty #parent "parent" (emptyProperties & defineStringProperty #foo "foo" "xxx")+ & defineStringProperty #baz "baz" "baz"++ examplePath1 = SingleKey #baz+ examplePath2 = ConsKeysPath #parent (SingleKey #foo)
+ test/Ide/TypesTests.hs view
@@ -0,0 +1,249 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE TypeFamilies #-}++module Ide.TypesTests+ ( tests+ ) where+import Control.Lens ((?~), (^?))+import Data.Default (Default (def))+import Data.Function ((&))+import Data.List.NonEmpty (NonEmpty ((:|)))+import Data.Maybe (isJust)+import qualified Data.Text as Text+import Ide.Types (PluginRequestMethod (combineResponses))+import qualified Language.LSP.Protocol.Lens as L+import Language.LSP.Protocol.Message (MessageParams, MessageResult,+ SMethod (..))+import Language.LSP.Protocol.Types (ClientCapabilities,+ Definition (Definition),+ DefinitionClientCapabilities (DefinitionClientCapabilities, _dynamicRegistration, _linkSupport),+ DefinitionLink (DefinitionLink),+ DefinitionParams (DefinitionParams, _partialResultToken, _position, _textDocument, _workDoneToken),+ Location (Location),+ LocationLink (LocationLink),+ Null (Null),+ Position (Position),+ Range (Range),+ TextDocumentClientCapabilities,+ TextDocumentIdentifier (TextDocumentIdentifier),+ TypeDefinitionClientCapabilities (TypeDefinitionClientCapabilities, _dynamicRegistration, _linkSupport),+ TypeDefinitionParams (..),+ Uri (Uri), _L, _R, _definition,+ _typeDefinition, filePathToUri,+ type (|?) (..))+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@=?))+import Test.Tasty.QuickCheck (ASCIIString (ASCIIString),+ Arbitrary (arbitrary), Gen,+ arbitraryBoundedEnum, cover,+ listOf1, oneof, testProperty,+ (===))++tests :: TestTree+tests = testGroup "PluginTypes"+ [ combineResponsesTests ]++combineResponsesTests :: TestTree+combineResponsesTests = testGroup "combineResponses"+ [ combineResponsesTextDocumentDefinitionTests+ , combineResponsesTextDocumentTypeDefinitionTests+ ]++combineResponsesTextDocumentDefinitionTests :: TestTree+combineResponsesTextDocumentDefinitionTests = testGroup "TextDocumentDefinition" $+ defAndTypeDefSharedTests SMethod_TextDocumentDefinition definitionParams++combineResponsesTextDocumentTypeDefinitionTests :: TestTree+combineResponsesTextDocumentTypeDefinitionTests = testGroup "TextDocumentTypeDefinition" $+ defAndTypeDefSharedTests SMethod_TextDocumentTypeDefinition typeDefinitionParams++defAndTypeDefSharedTests ::+ ( MessageResult m ~ (Definition |? ([DefinitionLink] |? Null))+ , PluginRequestMethod m+ )+ => SMethod m -> MessageParams m -> [TestTree]+defAndTypeDefSharedTests message params =+ [ testCase "merges all single location responses into one response with all locations (without upgrading to links)" $ do+ let pluginResponses :: NonEmpty (Definition |? ([DefinitionLink] |? Null))+ pluginResponses =+ (InL . Definition . InL . Location testFileUri $ range1) :|+ [ InL . Definition . InL . Location testFileUri $ range2+ , InL . Definition . InL . Location testFileUri $ range3+ ]++ result = combineResponses message def supportsLinkInAllDefinitionCaps params pluginResponses++ expectedResult :: Definition |? ([DefinitionLink] |? Null)+ expectedResult = InL . Definition . InR $+ [ Location testFileUri range1+ , Location testFileUri range2+ , Location testFileUri range3+ ]+ expectedResult @=? result++ , testCase "merges all location link responses into one with all links (with link support)" $ do+ let pluginResponses :: NonEmpty (Definition |? ([DefinitionLink] |? Null))+ pluginResponses =+ (InR . InL $ [DefinitionLink $ LocationLink Nothing testFileUri range1 range1]) :|+ [ InR . InL $+ [ DefinitionLink $ LocationLink Nothing testFileUri range2 range2+ , DefinitionLink $ LocationLink Nothing testFileUri range3 range3+ ]+ ]++ result = combineResponses message def supportsLinkInAllDefinitionCaps params pluginResponses++ expectedResult :: Definition |? ([DefinitionLink] |? Null)+ expectedResult = InR . InL $+ [ DefinitionLink $ LocationLink Nothing testFileUri range1 range1+ , DefinitionLink $ LocationLink Nothing testFileUri range2 range2+ , DefinitionLink $ LocationLink Nothing testFileUri range3 range3+ ]+ expectedResult @=? result++ , testCase "merges location responses with link responses into link responses (with link support)" $ do+ let pluginResponses :: NonEmpty (Definition |? ([DefinitionLink] |? Null))+ pluginResponses =+ (InL . Definition . InL . Location testFileUri $ range1) :|+ [ InR . InL $ [ DefinitionLink $ LocationLink Nothing testFileUri range2 range2 ]+ , InL . Definition . InR $ [Location testFileUri range3]+ ]++ result = combineResponses message def supportsLinkInAllDefinitionCaps params pluginResponses++ expectedResult :: Definition |? ([DefinitionLink] |? Null)+ expectedResult = InR . InL $+ [ DefinitionLink $ LocationLink Nothing testFileUri range1 range1+ , DefinitionLink $ LocationLink Nothing testFileUri range2 range2+ , DefinitionLink $ LocationLink Nothing testFileUri range3 range3+ ]+ expectedResult @=? result++ , testCase "preserves link-specific data when merging link and location responses (with link support)" $ do+ let pluginResponses :: NonEmpty (Definition |? ([DefinitionLink] |? Null))+ pluginResponses =+ (InL . Definition . InL . Location testFileUri $ range1) :|+ [ InR . InL $ [ DefinitionLink $ LocationLink (Just range1) testFileUri range2 range3 ] ]++ result = combineResponses message def supportsLinkInAllDefinitionCaps params pluginResponses++ expectedResult :: Definition |? ([DefinitionLink] |? Null)+ expectedResult = InR . InL $+ [ DefinitionLink $ LocationLink Nothing testFileUri range1 range1+ , DefinitionLink $ LocationLink (Just range1) testFileUri range2 range3+ ]+ expectedResult @=? result++ , testCase "ignores Null responses when other responses are available" $ do+ let pluginResponses :: NonEmpty (Definition |? ([DefinitionLink] |? Null))+ pluginResponses =+ (InL . Definition . InL . Location testFileUri $ range1) :|+ [ InR . InR $ Null+ , InR . InL $ [DefinitionLink $ LocationLink Nothing testFileUri range3 range3]+ ]++ result = combineResponses message def supportsLinkInAllDefinitionCaps params pluginResponses++ expectedResult :: Definition |? ([DefinitionLink] |? Null)+ expectedResult = InR . InL $+ [ DefinitionLink $ LocationLink Nothing testFileUri range1 range1+ , DefinitionLink $ LocationLink Nothing testFileUri range3 range3+ ]+ expectedResult @=? result++ , testCase "returns Null when all responses are Null" $ do+ let pluginResponses :: NonEmpty (Definition |? ([DefinitionLink] |? Null))+ pluginResponses =+ (InR . InR $ Null) :|+ [ InR . InR $ Null+ , InR . InR $ Null+ ]++ result = combineResponses message def supportsLinkInAllDefinitionCaps params pluginResponses++ expectedResult :: Definition |? ([DefinitionLink] |? Null)+ expectedResult = InR . InR $ Null+ expectedResult @=? result++ , testProperty "downgrades all locationLinks to locations when missing link support in capabilities" $ \(MkGeneratedNonEmpty responses) -> do+ let pluginResponses = fmap (\(MkGeneratedDefinition definition) -> definition) responses++ result = combineResponses message def def params pluginResponses++ cover 70 (any (isJust . (>>= (^? _L)) . (^? _R)) pluginResponses) "Has at least one response with links" $+ cover 10 (any (isJust . (^? _L)) pluginResponses) "Has at least one response with locations" $+ cover 10 (any (isJust . (>>= (^? _R)) . (^? _R)) pluginResponses) "Has at least one response with Null" $+ (isJust (result ^? _L) || isJust (result ^? _R >>= (^? _R))) === True+ ]+++range1, range2, range3 :: Range+range1 = Range (Position 3 0) $ Position 3 5+range2 = Range (Position 5 7) $ Position 5 13+range3 = Range (Position 24 30) $ Position 24 40++supportsLinkInAllDefinitionCaps :: ClientCapabilities+supportsLinkInAllDefinitionCaps = def & L.textDocument ?~ textDocumentCaps+ where+ textDocumentCaps :: TextDocumentClientCapabilities+ textDocumentCaps = def+ { _definition = Just DefinitionClientCapabilities { _linkSupport = Just True, _dynamicRegistration = Nothing }+ , _typeDefinition = Just TypeDefinitionClientCapabilities { _linkSupport = Just True, _dynamicRegistration = Nothing }+ }++definitionParams :: DefinitionParams+definitionParams = DefinitionParams+ { _textDocument = TextDocumentIdentifier testFileUri+ , _position = Position 5 4+ , _workDoneToken = Nothing+ , _partialResultToken = Nothing+ }++typeDefinitionParams :: TypeDefinitionParams+typeDefinitionParams = TypeDefinitionParams+ { _textDocument = TextDocumentIdentifier testFileUri+ , _position = Position 5 4+ , _workDoneToken = Nothing+ , _partialResultToken = Nothing+ }++testFileUri :: Uri+testFileUri = filePathToUri "file://tester/Test.hs"++newtype GeneratedDefinition = MkGeneratedDefinition (Definition |? ([DefinitionLink] |? Null)) deriving newtype (Show)++instance Arbitrary GeneratedDefinition where+ arbitrary = MkGeneratedDefinition <$> oneof+ [ InL . Definition . InL <$> generateLocation+ , InL . Definition . InR <$> listOf1 generateLocation+ , InR . InL . map DefinitionLink <$> listOf1 generateLocationLink+ , pure . InR . InR $ Null+ ]+ where+ generateLocation :: Gen Location+ generateLocation = do+ (LocationLink _ uri range _) <- generateLocationLink+ pure $ Location uri range++ generateLocationLink :: Gen LocationLink+ generateLocationLink = LocationLink <$> generateMaybe generateRange <*> generateUri <*> generateRange <*> generateRange++ generateMaybe :: Gen a -> Gen (Maybe a)+ generateMaybe gen = oneof [Just <$> gen, pure Nothing]++ generateUri :: Gen Uri+ generateUri = do+ (ASCIIString str) <- arbitrary+ pure . Uri . Text.pack $ str++ generateRange :: Gen Range+ generateRange = Range <$> generatePosition <*> generatePosition++ generatePosition :: Gen Position+ generatePosition = Position <$> arbitraryBoundedEnum <*> arbitraryBoundedEnum++newtype GeneratedNonEmpty a = MkGeneratedNonEmpty (NonEmpty a) deriving newtype (Show)++instance Arbitrary a => Arbitrary (GeneratedNonEmpty a) where+ arbitrary = MkGeneratedNonEmpty <$> ((:|) <$> arbitrary <*> arbitrary)
test/Main.hs view
@@ -1,6 +1,7 @@ module Main where import qualified Ide.PluginUtilsTest as PluginUtilsTest+import qualified Ide.TypesTests as PluginTypesTests import Test.Tasty import Test.Tasty.Ingredients.Rerun @@ -10,4 +11,5 @@ tests :: TestTree tests = testGroup "Main" [ PluginUtilsTest.tests+ , PluginTypesTests.tests ]