hls-plugin-api 1.6.0.0 → 2.14.0.0
raw patch · 15 files changed
Files
- bench/Main.hs +9/−9
- hls-plugin-api.cabal +45/−26
- src/Ide/Logger.hs +283/−0
- src/Ide/Plugin/Config.hs +23/−26
- src/Ide/Plugin/ConfigUtils.hs +149/−40
- src/Ide/Plugin/Error.hs +147/−0
- src/Ide/Plugin/HandleRequestTypes.hs +46/−0
- src/Ide/Plugin/Properties.hs +143/−39
- src/Ide/Plugin/RangeMap.hs +21/−11
- src/Ide/Plugin/Resolve.hs +211/−0
- src/Ide/PluginUtils.hs +152/−121
- src/Ide/Types.hs +1324/−982
- test/Ide/PluginUtilsTest.hs +132/−13
- 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: 1.6.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,12 +32,22 @@ 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.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 @@ -45,27 +55,33 @@ build-depends: , aeson , base >=4.12 && <5+ , co-log-core , containers , 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 ^>= 1.9+ , hls-graph == 2.14.0.0 , lens , lens-aeson- , lsp ^>=1.6.0.0+ , lsp ^>=2.8+ , megaparsec >=9.0+ , mtl , opentelemetry >=0.4 , optparse-applicative+ , prettyprinter , regex-tdfa >=1.3.1.0+ , stm , text+ , time , transformers+ , unliftio , unordered-containers- , megaparsec > 9 if os(windows) build-depends: Win32@@ -73,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
@@ -0,0 +1,283 @@+-- Copyright (c) 2019 The DAML Authors. All rights reserved.+-- SPDX-License-Identifier: Apache-2.0++{-# 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(..)+ , Recorder(..)+ , WithPriority(..)+ , logWith+ , cmap+ , cmapIO+ , cfilter+ , withFileRecorder+ , makeDefaultStderrRecorder+ , makeDefaultHandleRecorder+ , LoggingColumn(..)+ , cmapWithPrio+ , withBacklog+ , lspClientMessageRecorder+ , lspClientLogRecorder+ , module PrettyPrinterModule+ , renderStrict+ , toCologActionWithPrio+ , defaultLoggingColumns+ ) where++import Colog.Core (LogAction (..), Severity,+ WithSeverity (..))+import qualified Colog.Core as Colog+import Control.Concurrent (myThreadId)+import Control.Concurrent.Extra (Lock, newLock, withLock)+import Control.Concurrent.STM (atomically, flushTBQueue,+ isFullTBQueue, newTBQueueIO,+ newTVarIO, readTVarIO,+ writeTBQueue, writeTVar)+import Control.Exception (IOException)+import Control.Monad (unless, when, (>=>))+import Control.Monad.IO.Class (MonadIO (liftIO))+import Data.Foldable (for_)+import Data.Functor.Contravariant (Contravariant (contramap))+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.IO as Text+import Data.Time (defaultTimeLocale, formatTime,+ getCurrentTime)+import GHC.Stack (CallStack, HasCallStack,+ SrcLoc (SrcLoc, srcLocModule, srcLocStartCol, srcLocStartLine),+ callStack, getCallStack,+ withFrozenCallStack)+import Language.LSP.Protocol.Message (SMethod (SMethod_WindowLogMessage, SMethod_WindowShowMessage))+import Language.LSP.Protocol.Types (LogMessageParams (..),+ MessageType (..),+ ShowMessageParams (..))+import Language.LSP.Server+import qualified Language.LSP.Server as LSP+import Prettyprinter as PrettyPrinterModule+import Prettyprinter.Render.Text (renderStrict)+import System.IO (Handle, IOMode (AppendMode),+ hClose, hFlush, openFile,+ stderr)+import UnliftIO (MonadUnliftIO, finally, try)++data Priority+-- Don't change the ordering of this type or you will mess up the Ord+-- instance+ = Debug -- ^ Verbose debug logging.+ | Info -- ^ Useful information in case an error has to be understood.+ | Warning+ -- ^ These error messages should not occur in a expected usage, and+ -- should be investigated.+ | Error -- ^ Such log messages must never occur in expected usage.+ deriving (Eq, Show, Read, Ord, Enum, Bounded)++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.+-- 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 Recorder msg = Recorder+ { logger_ :: forall m. (MonadIO m) => msg -> m () }++logWith :: (HasCallStack, MonadIO m) => Recorder (WithPriority msg) -> Priority -> msg -> m ()+logWith recorder priority msg = withFrozenCallStack $ logger_ recorder (WithPriority priority callStack msg)++instance Semigroup (Recorder msg) where+ (<>) Recorder{ logger_ = logger_1 } Recorder{ logger_ = logger_2 } =+ Recorder+ { logger_ = \msg -> logger_1 msg >> logger_2 msg }++instance Monoid (Recorder msg) where+ mempty =+ Recorder+ { logger_ = \_ -> pure () }++instance Contravariant Recorder where+ contramap f Recorder{ logger_ } =+ Recorder+ { logger_ = logger_ . f }++cmap :: (a -> b) -> Recorder b -> Recorder a+cmap = contramap++cmapWithPrio :: (a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)+cmapWithPrio f = cmap (fmap f)++cmapIO :: (a -> IO b) -> Recorder b -> Recorder a+cmapIO f Recorder{ logger_ } =+ Recorder+ { logger_ = (liftIO . f) >=> logger_ }++cfilter :: (a -> Bool) -> Recorder a -> Recorder a+cfilter p Recorder{ logger_ } =+ Recorder+ { logger_ = \msg -> when (p msg) (logger_ msg) }++textHandleRecorder :: Handle -> Recorder Text+textHandleRecorder handle =+ Recorder+ { logger_ = \text -> liftIO $ Text.hPutStrLn handle text *> hFlush handle }++makeDefaultStderrRecorder :: MonadIO m => Maybe [LoggingColumn] -> m (Recorder (WithPriority (Doc a)))+makeDefaultStderrRecorder columns = do+ lock <- liftIO newLock+ makeDefaultHandleRecorder columns lock stderr++withFileRecorder+ :: MonadUnliftIO m+ => FilePath+ -- ^ Log file path.+ -> Maybe [LoggingColumn]+ -- ^ logging columns to display. `Nothing` uses `defaultLoggingColumns`+ -> (Either IOException (Recorder (WithPriority (Doc d))) -> m a)+ -- ^ action given a recorder, or the exception if we failed to open the file+ -> m a+withFileRecorder path columns action = do+ lock <- liftIO newLock+ let makeHandleRecorder = makeDefaultHandleRecorder columns lock+ fileHandle :: Either IOException Handle <- liftIO $ try (openFile path AppendMode)+ case fileHandle of+ Left e -> action $ Left e+ Right fileHandle -> finally (makeHandleRecorder fileHandle >>= action . Right) (liftIO $ hClose fileHandle)++makeDefaultHandleRecorder+ :: MonadIO m+ => Maybe [LoggingColumn]+ -- ^ built-in logging columns to display. Nothing uses the default+ -> Lock+ -- ^ lock to take when outputting to handle+ -> Handle+ -- ^ handle to output to+ -> m (Recorder (WithPriority (Doc a)))+makeDefaultHandleRecorder columns lock handle = do+ let Recorder{ logger_ } = textHandleRecorder handle+ let threadSafeRecorder = Recorder { logger_ = \msg -> liftIO $ withLock lock (logger_ msg) }+ let loggingColumns = fromMaybe defaultLoggingColumns columns+ let textWithPriorityRecorder = cmapIO (textWithPriorityToText loggingColumns) threadSafeRecorder+ pure (cmap docToText textWithPriorityRecorder)+ where+ docToText = fmap (renderStrict . layoutPretty defaultLayoutOptions)++data LoggingColumn+ = TimeColumn+ | ThreadIdColumn+ | PriorityColumn+ | DataColumn+ | SourceLocColumn++defaultLoggingColumns :: [LoggingColumn]+defaultLoggingColumns = [TimeColumn, PriorityColumn, DataColumn]++textWithPriorityToText :: [LoggingColumn] -> WithPriority Text -> IO Text+textWithPriorityToText columns WithPriority{ priority, callStack_, payload } = do+ textColumns <- mapM loggingColumnToText columns+ pure $ Text.intercalate " | " textColumns+ where+ showAsText :: Show a => a -> Text+ showAsText = Text.pack . show++ utcTimeToText utcTime = Text.pack $ formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%6QZ" utcTime++ priorityToText :: Priority -> Text+ priorityToText = showAsText++ threadIdToText = showAsText++ callStackToSrcLoc :: CallStack -> Maybe SrcLoc+ callStackToSrcLoc callStack =+ case getCallStack callStack of+ (_, srcLoc) : _ -> Just srcLoc+ _ -> Nothing++ srcLocToText = \case+ Nothing -> "<unknown>"+ Just SrcLoc{ srcLocModule, srcLocStartLine, srcLocStartCol } ->+ Text.pack srcLocModule <> "#" <> showAsText srcLocStartLine <> ":" <> showAsText srcLocStartCol++ loggingColumnToText :: LoggingColumn -> IO Text+ loggingColumnToText = \case+ TimeColumn -> do+ utcTime <- getCurrentTime+ pure (utcTimeToText utcTime)+ SourceLocColumn -> pure $ (srcLocToText . callStackToSrcLoc) callStack_+ ThreadIdColumn -> do+ threadId <- myThreadId+ pure (threadIdToText threadId)+ PriorityColumn -> pure (priorityToText priority)+ DataColumn -> pure payload++-- | Given a 'Recorder' that requires an argument, produces a 'Recorder'+-- that queues up messages until the argument is provided using the callback, at which+-- point it sends the backlog and begins functioning normally.+withBacklog :: (v -> Recorder a) -> IO (Recorder a, v -> IO ())+withBacklog recFun = do+ -- Arbitrary backlog capacity+ backlog <- newTBQueueIO 100+ let backlogRecorder = Recorder $ \it -> liftIO $ atomically $ do+ -- If the queue is full just drop the message on the floor. This is most likely+ -- to happen if the callback is just never going to be called; in which case+ -- we want neither to build up an unbounded backlog in memory, nor block waiting+ -- for space!+ full <- isFullTBQueue backlog+ unless full $ writeTBQueue backlog it++ -- The variable holding the recorder starts out holding the recorder that writes+ -- to the backlog.+ recVar <- newTVarIO backlogRecorder+ -- The callback atomically swaps out the recorder for the final one, and flushes+ -- the backlog to it.+ let cb arg = do+ let recorder = recFun arg+ toRecord <- atomically $ writeTVar recVar recorder >> flushTBQueue backlog+ for_ toRecord (logger_ recorder)++ -- The recorder we actually return looks in the variable and uses whatever is there.+ let varRecorder = Recorder $ \it -> do+ r <- liftIO $ readTVarIO recVar+ logger_ r it++ pure (varRecorder, cb)++-- | Creates a recorder that sends logs to the LSP client via @window/showMessage@ notifications.+lspClientMessageRecorder :: LanguageContextEnv config -> Recorder (WithPriority Text)+lspClientMessageRecorder env = Recorder $ \WithPriority {..} ->+ liftIO $ LSP.runLspT env $ LSP.sendNotification SMethod_WindowShowMessage+ ShowMessageParams+ { _type_ = priorityToLsp priority,+ _message = payload+ }++-- | Creates a recorder that sends logs to the LSP client via @window/logMessage@ notifications.+lspClientLogRecorder :: LanguageContextEnv config -> Recorder (WithPriority Text)+lspClientLogRecorder env = Recorder $ \WithPriority {..} ->+ liftIO $ LSP.runLspT env $ LSP.sendNotification SMethod_WindowLogMessage+ LogMessageParams+ { _type_ = priorityToLsp priority,+ _message = payload+ }++priorityToLsp :: Priority -> MessageType+priorityToLsp =+ \case+ Debug -> MessageType_Log+ Info -> MessageType_Info+ Warning -> MessageType_Warning+ Error -> MessageType_Error++toCologActionWithPrio :: (MonadIO m, HasCallStack) => Recorder (WithPriority msg) -> LogAction m (WithSeverity msg)+toCologActionWithPrio (Recorder _logger) = LogAction $ \WithSeverity{..} -> do+ let priority = severityToPriority getSeverity+ _logger $ WithPriority priority callStack getMsg+ where+ severityToPriority :: Severity -> Priority+ severityToPriority Colog.Debug = Debug+ severityToPriority Colog.Info = Info+ severityToPriority Colog.Warning = Warning+ severityToPriority Colog.Error = Error
src/Ide/Plugin/Config.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-}@@ -11,17 +10,16 @@ , CheckParents(..) ) where -import Control.Applicative-import Control.Lens (preview)-import Data.Aeson hiding (Error)-import qualified Data.Aeson as A-import Data.Aeson.Lens (_String)-import qualified Data.Aeson.Types as A+import Control.Lens (preview)+import Data.Aeson hiding (Error)+import qualified Data.Aeson as A+import Data.Aeson.Lens (_String)+import qualified Data.Aeson.Types as A import Data.Default-import qualified Data.Map.Strict as Map-import Data.Maybe (fromMaybe)-import qualified Data.Text as T-import GHC.Exts (toList)+import qualified Data.Map.Strict as Map+import Data.Maybe (fromMaybe)+import qualified Data.Text as T+import GHC.Exts (toList) import Ide.Types -- ---------------------------------------------------------------------@@ -37,19 +35,15 @@ -- --------------------------------------------------------------------- parseConfig :: IdePlugins s -> Config -> Value -> A.Parser Config-parseConfig idePlugins defValue = A.withObject "Config" $ \v -> do- -- Officially, we use "haskell" as the section name but for- -- backwards compatibility we also accept "languageServerHaskell"- c <- v .: "haskell" <|> v .:? "languageServerHaskell"- case c of- Nothing -> return defValue- Just s -> flip (A.withObject "Config.settings") s $ \o -> Config- <$> (o .:? "checkParents" <|> v .:? "checkParents") .!= checkParents defValue- <*> (o .:? "checkProject" <|> v .:? "checkProject") .!= checkProject defValue- <*> o .:? "formattingProvider" .!= formattingProvider defValue- <*> o .:? "cabalFormattingProvider" .!= cabalFormattingProvider defValue- <*> o .:? "maxCompletions" .!= maxCompletions defValue- <*> A.explicitParseFieldMaybe (parsePlugins idePlugins) o "plugin" .!= plugins defValue+parseConfig idePlugins defValue = A.withObject "settings" $ \o ->+ Config+ <$> o .:? "checkParents" .!= checkParents defValue+ <*> o .:? "checkProject" .!= checkProject defValue+ <*> 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'. -- Since we need to fall back to default values if we do not find one in the input,@@ -69,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,22 +3,34 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} -module Ide.Plugin.ConfigUtils where+module Ide.Plugin.ConfigUtils (+ pluginsToDefaultConfig,+ pluginsToVSCodeExtensionSchema,+ pluginsCustomConfigToMarkdownTables+ ) where -import Control.Lens (at, ix, (&), (?~))-import qualified Data.Aeson as A-import Data.Aeson.Lens (_Object)-import qualified Data.Aeson.Types as A+import Control.Lens (at, (&), (?~))+import qualified Data.Aeson as A+import Data.Aeson.Lens (_Object)+import qualified Data.Aeson.Types as A import Data.Default-import qualified Data.Dependent.Map as DMap-import qualified Data.Dependent.Sum as DSum-import Data.List.Extra (nubOrd)-import Data.String (IsString (fromString))-import qualified Data.Text as T+import qualified Data.Dependent.Map as DMap+import qualified Data.Dependent.Sum as DSum+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, toVSCodeExtensionSchema)+import Ide.Plugin.Properties (KeyNameProxy, MetaData (..),+ PluginCustomConfig (..),+ PluginCustomConfigParam (..),+ Properties (..),+ SPropertyKey (..),+ SomePropertyKeyWithMetaData (..),+ toDefaultJSON,+ toVSCodeExtensionSchema) import Ide.Types-import Language.LSP.Types+import Language.LSP.Protocol.Message -- Attention: -- 'diagnosticsOn' will never be added into the default config or the schema,@@ -28,13 +40,12 @@ -- | Generates a default 'Config', but remains only effective items pluginsToDefaultConfig :: IdePlugins a -> A.Value pluginsToDefaultConfig IdePlugins {..} =- -- Use 'ix' to look at all the "haskell" keys in the outer value (since we're not- -- setting it if missing), then we use '_Object' and 'at' to get at the "plugin" key+ -- Use '_Object' and 'at' to get at the "plugin" key -- and actually set it.- A.toJSON defaultConfig & ix "haskell" . _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:@@ -86,13 +98,17 @@ -- This function captures ide methods registered by the plugin, and then converts it to kv pairs handlersToGenericDefaultConfig :: PluginConfig -> DSum.DSum IdeMethod f -> [A.Pair] handlersToGenericDefaultConfig PluginConfig{..} (IdeMethod m DSum.:=> _) = case m of- STextDocumentCodeAction -> ["codeActionsOn" A..= plcCodeActionsOn]- STextDocumentCodeLens -> ["codeLensOn" A..= plcCodeLensOn]- STextDocumentRename -> ["renameOn" A..= plcRenameOn]- STextDocumentHover -> ["hoverOn" A..= plcHoverOn]- STextDocumentDocumentSymbol -> ["symbolsOn" A..= plcSymbolsOn]- STextDocumentCompletion -> ["completionOn" A..= plcCompletionOn]- STextDocumentPrepareCallHierarchy -> ["callHierarchyOn" A..= plcCallHierarchyOn]+ 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- STextDocumentCodeAction -> [toKey' "codeActionsOn" A..= schemaEntry "code actions"]- STextDocumentCodeLens -> [toKey' "codeLensOn" A..= schemaEntry "code lenses"]- STextDocumentRename -> [toKey' "renameOn" A..= schemaEntry "rename"]- STextDocumentHover -> [toKey' "hoverOn" A..= schemaEntry "hover"]- STextDocumentDocumentSymbol -> [toKey' "symbolsOn" A..= schemaEntry "symbols"]- STextDocumentCompletion -> [toKey' "completionOn" A..= schemaEntry "completions"]- STextDocumentPrepareCallHierarchy -> [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
@@ -0,0 +1,147 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+module Ide.Plugin.Error (+ -- * Plugin Error Handling API+ PluginError(..),+ toErrorCode,+ toPriority,+ handleMaybe,+ handleMaybeM,+ 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 Ide.Logger+import Ide.Plugin.HandleRequestTypes (RejectionReason)+import Language.LSP.Protocol.Types++-- ----------------------------------------------------------------------------+-- Plugin Error wrapping+-- ----------------------------------------------------------------------------++-- |Each PluginError corresponds to either a specific ResponseError we want to+-- return or a specific way we want to log the error. If the currently present+-- ones are insufficient for the needs of your plugin, please feel free to add+-- a new one.+--+-- Currently the PluginErrors we provide can be broken up into several groups.+-- First is PluginInternalError, which is the most serious of the errors, and+-- also the "default" error that is used for things such as uncaught exceptions.+-- Then we have PluginInvalidParams, which along with PluginInternalError map+-- to a corresponding ResponseError.+--+-- Next we have PluginRuleFailed and PluginInvalidUserState, with the only+-- difference being PluginRuleFailed is specific to Shake rules and+-- PluginInvalidUserState can be used for everything else. Both of these are+-- "non-errors", and happen whenever the user's code is in a state where the+-- plugin is unable to provide a answer to the users request. PluginStaleResolve+-- is similar to the above two Error types, but is specific to resolve plugins,+-- and is used only when the data provided by the resolve request is stale,+-- preventing the proper resolution of it.+--+-- Finally we have the outlier, PluginRequestRefused, where we allow a handler+-- to preform "pluginEnabled" checks inside the handler, and reject the request+-- after viewing it. The behavior of only one handler passing `pluginEnabled`+-- and then returning PluginRequestRefused should be the same as if no plugins+-- passed the `pluginEnabled` stage.+data PluginError+ = -- |PluginInternalError should be used if an error has occurred. This+ -- should only rarely be returned. As it's logged with Error, it will be+ -- shown by the client to the user via `showWindow`. All uncaught exceptions+ -- will be caught and converted to this error.+ --+ -- This error will be be converted into an InternalError response code. It+ -- will be logged with Error and takes the highest precedence (1) in being+ -- returned as a response to the client.+ PluginInternalError T.Text+ -- |PluginInvalidParams should be used if the parameters of the request are+ -- invalid. This error means that there is a bug in the client's code+ -- (otherwise they wouldn't be sending you requests with invalid+ -- parameters).+ --+ -- This error will be will be converted into a InvalidParams response code.+ -- It will be logged with Warning and takes medium precedence (2) in being+ -- returned as a response to the client.+ | PluginInvalidParams T.Text+ -- |PluginInvalidUserState should be thrown when a function that your plugin+ -- depends on fails. This should only be used when the function fails+ -- because the user's code is in an invalid state.+ --+ -- This error takes the name of the function that failed. Prefer to catch+ -- this error as close to the source as possible.+ --+ -- This error will be logged with Debug, and will be converted into a+ -- RequestFailed response. It takes a low precedence (3) in being returned+ -- as a response to the client.+ | 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+ -- `handlesRequest` decision after receiving the request. This should only be+ -- used if the decision to accept the request can not be made in+ -- `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 `handlesRequest` stage.+ | PluginRequestRefused RejectionReason+ -- |PluginRuleFailed should be thrown when a Rule your response depends on+ -- fails.+ --+ -- This error takes the name of the Rule that failed.+ --+ -- This error will be logged with Debug, and will be converted into a+ -- RequestFailed response code. It takes a low precedence (3) in being+ -- returned as a response to the client.+ | PluginRuleFailed T.Text+ -- |PluginStaleResolve should be thrown when your resolve request is+ -- provided with data it can no longer resolve.+ --+ -- This error will be logged with Debug, and will be converted into a+ -- ContentModified response. It takes a low precedence (3) in being returned+ -- as a response to the client.+ | PluginStaleResolve++instance Pretty PluginError where+ pretty = \case+ PluginInternalError msg -> "Internal Error:" <+> pretty msg+ PluginStaleResolve -> "Stale Resolve"+ PluginRuleFailed rule -> "Rule Failed:" <+> pretty rule+ PluginInvalidParams text -> "Invalid Params:" <+> pretty text+ PluginInvalidUserState text -> "Invalid User State:" <+> pretty text+ PluginRequestRefused msg -> "Request Refused: " <+> pretty msg++-- |Converts to ErrorCode used in LSP ResponseErrors+toErrorCode :: PluginError -> (LSPErrorCodes |? ErrorCodes)+toErrorCode (PluginInternalError _) = InR ErrorCodes_InternalError+toErrorCode (PluginInvalidParams _) = InR ErrorCodes_InvalidParams+toErrorCode (PluginInvalidUserState _) = InL LSPErrorCodes_RequestFailed+-- PluginRequestRefused should never be a argument to `toResponseError`, as+-- it should be dealt with in `extensiblePlugins`, but this is here to make+-- this function complete+toErrorCode (PluginRequestRefused _) = InR ErrorCodes_MethodNotFound+toErrorCode (PluginRuleFailed _) = InL LSPErrorCodes_RequestFailed+toErrorCode PluginStaleResolve = InL LSPErrorCodes_ContentModified++-- |Converts to a logging priority. In addition to being used by the logger,+-- `combineResponses` currently uses this to choose which response to return,+-- so care should be taken in changing it.+toPriority :: PluginError -> Priority+toPriority (PluginInternalError _) = Error+toPriority (PluginInvalidParams _) = Warning+toPriority (PluginInvalidUserState _) = Debug+toPriority (PluginRequestRefused _) = Debug+toPriority (PluginRuleFailed _) = Debug+toPriority PluginStaleResolve = Debug++handleMaybe :: Monad m => e -> Maybe b -> ExceptT e m b+handleMaybe msg = maybe (throwE msg) return++handleMaybeM :: Monad m => e -> m (Maybe b) -> ExceptT e m b+handleMaybeM msg act = maybeM (throwE msg) return $ lift act++getNormalizedFilePathE :: Monad m => Uri -> ExceptT PluginError m NormalizedFilePath+getNormalizedFilePathE uri = handleMaybe (PluginInvalidParams (T.pack $ "uriToNormalizedFile failed. Uri:" <> show uri))+ $ uriToNormalizedFilePath+ $ toNormalizedUri uri
+ 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,18 +13,24 @@ fromList, fromList', filterByRange,+ elementsInRange, ) where -import Data.Bifunctor (first)-import Data.Foldable (foldl') import Development.IDE.Graph.Classes (NFData)-import Language.LSP.Types (Position,- Range (Range),- isSubrangeOf)+ #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@@ -64,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
@@ -0,0 +1,211 @@+{-# LANGUAGE DisambiguateRecordFields #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-| 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+mkCodeActionHandlerWithResolve will immediately resolve your code action before+sending it on to the client, while mkCodeActionWithResolveAndCommand will turn+your resolve into a command.++General support for resolve in HLS can be used with mkResolveHandler from+Ide.Types. Resolve theoretically should allow us to delay computation of parts+of the request till the client needs it, allowing us to answer requests faster+and with less resource usage.+-}+module Ide.Plugin.Resolve+(mkCodeActionHandlerWithResolve,+mkCodeActionWithResolveAndCommand) where++import Control.Lens (_Just, (&), (.~), (?~), (^.),+ (^?))+import Control.Monad.Error.Class (MonadError (throwError))+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Except (ExceptT (..))++import qualified Data.Aeson as A+import Data.Maybe (catMaybes)+import qualified Data.Text as T+import GHC.Generics (Generic)+import Ide.Logger+import Ide.Plugin.Error+import Ide.Types+import qualified Language.LSP.Protocol.Lens as L+import Language.LSP.Protocol.Message+import Language.LSP.Protocol.Types++data Log+ = DoesNotSupportResolve T.Text+ | forall m . A.ToJSON (ErrorData m) => ApplyWorkspaceEditFailed (TResponseError m)+instance Pretty Log where+ pretty = \case+ DoesNotSupportResolve fallback->+ "Client does not support resolve," <+> pretty fallback+ ApplyWorkspaceEditFailed err ->+ "ApplyWorkspaceEditFailed:" <+> pretty err++-- |When provided with both a codeAction provider and an affiliated codeAction+-- resolve provider, this function creates a handler that automatically uses+-- your resolve provider to fill out you original codeAction if the client doesn't+-- have codeAction resolve support. This means you don't have to check whether+-- the client supports resolve and act accordingly in your own providers.+mkCodeActionHandlerWithResolve+ :: forall ideState a. (A.FromJSON a) =>+ Recorder (WithPriority Log)+ -> PluginMethodHandler ideState 'Method_TextDocumentCodeAction+ -> ResolveFunction ideState a 'Method_CodeActionResolve+ -> PluginHandlers ideState+mkCodeActionHandlerWithResolve recorder codeActionMethod codeResolveMethod =+ let newCodeActionMethod ideState pid params =+ do codeActionReturn <- codeActionMethod ideState pid params+ caps <- lift pluginGetClientCapabilities+ case codeActionReturn of+ r@(InR Null) -> pure r+ (InL ls) | -- We don't need to do anything if the client supports+ -- resolve+ supportsCodeActionResolve caps -> pure $ InL ls+ --This is the actual part where we call resolveCodeAction which fills in the edit data for the client+ | otherwise -> do+ logWith recorder Debug (DoesNotSupportResolve "filling in the code action")+ InL <$> traverse (resolveCodeAction (params ^. L.textDocument . L.uri) ideState pid) ls+ in (mkPluginHandler SMethod_TextDocumentCodeAction newCodeActionMethod+ <> mkResolveHandler SMethod_CodeActionResolve codeResolveMethod)+ where dropData :: CodeAction -> CodeAction+ dropData ca = ca & L.data_ .~ Nothing+ 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+ A.Error err -> throwError $ parseError (Just value) (T.pack err)+ A.Success innerValueDecoded -> do+ resolveResult <- codeResolveMethod ideState pid codeAction uri innerValueDecoded+ case resolveResult of+ CodeAction {_edit = Just _ } -> do+ pure $ InR $ dropData resolveResult+ _ -> throwError $ invalidParamsError "Returned CodeAction has no data field"+ resolveCodeAction _ _ _ (InR CodeAction{_data_=Nothing}) = throwError $ invalidParamsError "CodeAction has no data field"+++-- |When provided with both a codeAction provider with a data field and a resolve+-- provider, this function creates a handler that creates a command that uses+-- your resolve if the client doesn't have code action resolve support. This means+-- you don't have to check whether the client supports resolve and act+-- accordingly in your own providers. see Note [Code action resolve fallback to commands]+-- Also: This helper only works with workspace edits, not commands. Any command set+-- either in the original code action or in the resolve will be ignored.+mkCodeActionWithResolveAndCommand+ :: forall ideState a. (A.FromJSON a) =>+ Recorder (WithPriority Log)+ -> PluginId+ -> PluginMethodHandler ideState 'Method_TextDocumentCodeAction+ -> ResolveFunction ideState a 'Method_CodeActionResolve+ -> ([PluginCommand ideState], PluginHandlers ideState)+mkCodeActionWithResolveAndCommand recorder plId codeActionMethod codeResolveMethod =+ let newCodeActionMethod ideState pid params =+ do codeActionReturn <- codeActionMethod ideState pid params+ caps <- lift pluginGetClientCapabilities+ case codeActionReturn of+ r@(InR Null) -> pure r+ (InL ls) | -- We don't need to do anything if the client supports+ -- resolve+ supportsCodeActionResolve caps -> pure $ InL ls+ -- If they do not we will drop the data field, in addition we will populate the command+ -- field with our command to execute the resolve, with the whole code action as it's argument.+ | otherwise -> do+ logWith recorder Debug (DoesNotSupportResolve "rewriting the code action to use commands")+ pure $ InL $ moveDataToCommand (params ^. L.textDocument . L.uri) <$> ls+ in ([PluginCommand "codeActionResolve" "Executes resolve for code action" (executeResolveCmd codeResolveMethod)],+ mkPluginHandler SMethod_TextDocumentCodeAction newCodeActionMethod+ <> mkResolveHandler SMethod_CodeActionResolve codeResolveMethod)+ where moveDataToCommand :: Uri -> Command |? CodeAction -> Command |? CodeAction+ moveDataToCommand uri ca =+ let dat = A.toJSON . wrapWithURI uri <$> ca ^? _R -- We need to take the whole codeAction+ -- And put it in the argument for the Command, that way we can later+ -- pass it to the resolve handler (which expects a whole code action)+ -- It should be noted that mkLspCommand already specifies the command+ -- to the plugin, so we don't need to do that here.+ cmd = mkLspCommand plId (CommandId "codeActionResolve") "Execute Code Action" (pure <$> dat)+ in ca+ & _R . L.data_ .~ Nothing -- Set the data field to nothing+ & _R . L.command ?~ cmd -- And set the command to our previously created command+ wrapWithURI :: Uri -> CodeAction -> CodeAction+ wrapWithURI uri codeAction =+ 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 _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 ()+ handleWEditCallback _ = pure ()++-- TODO: Remove once provided by lsp-types+-- |Compares two CodeActions and returns a list of fields that are not equal+diffCodeActions :: CodeAction -> CodeAction -> [T.Text]+diffCodeActions ca ca2 =+ let titleDiff = if ca ^. L.title == ca2 ^. L.title then Nothing else Just "title"+ kindDiff = if ca ^. L.kind == ca2 ^. L.kind then Nothing else Just "kind"+ diagnosticsDiff = if ca ^. L.diagnostics == ca2 ^. L.diagnostics then Nothing else Just "diagnostics"+ commandDiff = if ca ^. L.command == ca2 ^. L.command then Nothing else Just "diagnostics"+ isPreferredDiff = if ca ^. L.isPreferred == ca2 ^. L.isPreferred then Nothing else Just "isPreferred"+ dataDiff = if ca ^. L.data_ == ca2 ^. L.data_ then Nothing else Just "data"+ disabledDiff = if ca ^. L.disabled == ca2 ^. L.disabled then Nothing else Just "disabled"+ editDiff = if ca ^. L.edit == ca2 ^. L.edit then Nothing else Just "edit"+ in catMaybes [titleDiff, kindDiff, diagnosticsDiff, commandDiff, isPreferredDiff, dataDiff, disabledDiff, editDiff]++-- |To execute the resolve provider as a command, we need to additionally store+-- the URI that was provided to the original code action.+data WithURI = WithURI {+ _uri :: Uri+, _value :: A.Value+} deriving (Generic, Show)+instance A.ToJSON WithURI+instance A.FromJSON WithURI++-- |Checks if the the client supports resolve for code action. We currently only check+-- whether resolve for the edit field is supported, because that's the only one we care+-- about at the moment.+supportsCodeActionResolve :: ClientCapabilities -> Bool+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 ClientCodeActionResolveOptions{_properties} -> "edit" `elem` _properties+ _ -> False++internalError :: T.Text -> PluginError+internalError msg = PluginInternalError ("Ide.Plugin.Resolve: " <> msg)++invalidParamsError :: T.Text -> PluginError+invalidParamsError msg = PluginInvalidParams ("Ide.Plugin.Resolve: : " <> msg)++parseError :: Maybe A.Value -> T.Text -> PluginError+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.+ The way we do this is to have them always implement a resolve handler.+ Then, if the client doesn't support resolve, we instead install the resolve+ handler as a _command_ handler, passing the code action literal itself+ as the command argument. This allows the command handler to have+ the same interface as the resolve handler!+ -}
src/Ide/PluginUtils.hs view
@@ -1,11 +1,12 @@-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-}+ module Ide.PluginUtils ( -- * LSP Range manipulation functions normalize, extendNextLine, extendLineStart,+ extendToFullLines, WithDeletions(..), getProcessID, makeDiffTextEdit,@@ -14,12 +15,11 @@ diffText', pluginDescToIdePlugins, idePluginsToPluginDesc,- responseError, getClientConfig, getPluginConfig, configForPlugin,- pluginEnabled,- extractRange,+ handlesRequest,+ extractTextInRange, fullRange, mkLspCommand, mkLspCmdId,@@ -28,44 +28,35 @@ allLspCmdIds', installSigUsr1Handler, subRange,+ rangesOverlap, positionInRange, usePropertyLsp,- getNormalizedFilePath,- pluginResponse,- handleMaybe,- handleMaybeM,- throwPluginError,+ -- * Escape unescape,- )+ -- * toAbsolute+ toAbsolute+ ) where --import Control.Arrow ((&&&))-import Control.Monad.Extra (maybeM)-import Control.Monad.Trans.Class (lift)-import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE)+import Control.Arrow ((&&&))+import Control.Lens (_head, _last, re, (%~), (^.)) import Data.Algorithm.Diff import Data.Algorithm.DiffOutput-import Data.Bifunctor (Bifunctor (first))-import Data.Char (isPrint, showLitChar)-import Data.Functor (void)-import qualified Data.HashMap.Strict as H-import Data.String (IsString (fromString))-import qualified Data.Text as T-import Data.Void (Void)+import Data.Char (isPrint, showLitChar)+import Data.Functor (void)+import qualified Data.Map as M+import qualified Data.Text as T+import Data.Void (Void) import Ide.Plugin.Config import Ide.Plugin.Properties import Ide.Types+import qualified Language.LSP.Protocol.Lens as L+import Language.LSP.Protocol.Types import Language.LSP.Server-import Language.LSP.Types hiding- (SemanticTokenAbsolute (length, line),- SemanticTokenRelative (length),- SemanticTokensEdit (_start))-import qualified Language.LSP.Types as J-import Language.LSP.Types.Capabilities-import qualified Text.Megaparsec as P-import qualified Text.Megaparsec.Char as P-import qualified Text.Megaparsec.Char.Lexer as P+import System.FilePath ((</>))+import qualified Text.Megaparsec as P+import qualified Text.Megaparsec.Char as P+import qualified Text.Megaparsec.Char.Lexer as P -- --------------------------------------------------------------------- @@ -92,39 +83,56 @@ extendLineStart (Range (Position sl _) e) = Range (Position sl 0) e +-- | Extend 'Range' to include the start of the first line and start of the next line of the last line.+--+-- Caveat: It always extend the last line to the beginning of next line, even when the last position is at column 0.+-- This is to keep the compatibility with the implementation of old function @extractRange@.+--+-- >>> extendToFullLines (Range (Position 5 5) (Position 5 10))+-- Range (Position 5 0) (Position 6 0)+--+-- >>> extendToFullLines (Range (Position 5 5) (Position 7 2))+-- Range (Position 5 0) (Position 8 0)+--+-- >>> extendToFullLines (Range (Position 5 5) (Position 7 0))+-- Range (Position 5 0) (Position 8 0)+extendToFullLines :: Range -> Range+extendToFullLines = extendLineStart . extendNextLine++ -- --------------------------------------------------------------------- data WithDeletions = IncludeDeletions | SkipDeletions- deriving Eq+ deriving (Eq) -- | Generate a 'WorkspaceEdit' value from a pair of source Text-diffText :: ClientCapabilities -> (Uri,T.Text) -> T.Text -> WithDeletions -> WorkspaceEdit+diffText :: ClientCapabilities -> (VersionedTextDocumentIdentifier, T.Text) -> T.Text -> WithDeletions -> WorkspaceEdit diffText clientCaps old new withDeletions =- let- supports = clientSupportsDocumentChanges clientCaps- in diffText' supports old new withDeletions+ let supports = clientSupportsDocumentChanges clientCaps+ in diffText' supports old new withDeletions -makeDiffTextEdit :: T.Text -> T.Text -> List TextEdit+makeDiffTextEdit :: T.Text -> T.Text -> [TextEdit] makeDiffTextEdit f1 f2 = diffTextEdit f1 f2 IncludeDeletions -makeDiffTextEditAdditive :: T.Text -> T.Text -> List TextEdit+makeDiffTextEditAdditive :: T.Text -> T.Text -> [TextEdit] makeDiffTextEditAdditive f1 f2 = diffTextEdit f1 f2 SkipDeletions -diffTextEdit :: T.Text -> T.Text -> WithDeletions -> List TextEdit-diffTextEdit fText f2Text withDeletions = J.List r+diffTextEdit :: T.Text -> T.Text -> WithDeletions -> [TextEdit]+diffTextEdit fText f2Text withDeletions = r where r = map diffOperationToTextEdit diffOps d = getGroupedDiff (lines $ T.unpack fText) (lines $ T.unpack f2Text) - diffOps = filter (\x -> (withDeletions == IncludeDeletions) || not (isDeletion x))- (diffToLineRanges d)+ diffOps =+ filter+ (\x -> (withDeletions == IncludeDeletions) || not (isDeletion x))+ (diffToLineRanges d) isDeletion (Deletion _ _) = True isDeletion _ = False -- diffOperationToTextEdit :: DiffOperation LineRange -> J.TextEdit- diffOperationToTextEdit (Change fm to) = J.TextEdit range nt+ diffOperationToTextEdit :: DiffOperation LineRange -> TextEdit+ diffOperationToTextEdit (Change fm to) = TextEdit range nt where range = calcRange fm nt = T.pack $ init $ unlines $ lrContents to@@ -136,53 +144,54 @@ the line ending character(s) then use an end position denoting the start of the next line" -}- diffOperationToTextEdit (Deletion (LineRange (sl, el) _) _) = J.TextEdit range ""+ diffOperationToTextEdit (Deletion (LineRange (sl, el) _) _) = TextEdit range "" where- range = J.Range (J.Position (fromIntegral $ sl - 1) 0)- (J.Position (fromIntegral el) 0)-- diffOperationToTextEdit (Addition fm l) = J.TextEdit range nt- -- fm has a range wrt to the changed file, which starts in the current file at l + 1- -- So the range has to be shifted to start at l + 1+ range =+ Range+ (Position (fromIntegral $ sl - 1) 0)+ (Position (fromIntegral el) 0)+ diffOperationToTextEdit (Addition fm l) = TextEdit range nt where- range = J.Range (J.Position (fromIntegral l) 0)- (J.Position (fromIntegral l) 0)- nt = T.pack $ unlines $ lrContents fm+ -- fm has a range wrt to the changed file, which starts in the current file at l + 1+ -- So the range has to be shifted to start at l + 1 + range =+ Range+ (Position (fromIntegral l) 0)+ (Position (fromIntegral l) 0)+ nt = T.pack $ unlines $ lrContents fm - calcRange fm = J.Range s e+ calcRange fm = Range s e where sl = fst $ lrNumbers fm sc = 0- s = J.Position (fromIntegral $ sl - 1) sc -- Note: zero-based lines+ s = Position (fromIntegral $ sl - 1) sc -- Note: zero-based lines el = snd $ lrNumbers fm ec = fromIntegral $ length $ last $ lrContents fm- e = J.Position (fromIntegral $ el - 1) ec -- Note: zero-based lines-+ e = Position (fromIntegral $ el - 1) ec -- Note: zero-based lines -- | A pure version of 'diffText' for testing-diffText' :: Bool -> (Uri,T.Text) -> T.Text -> WithDeletions -> WorkspaceEdit-diffText' supports (f,fText) f2Text withDeletions =+diffText' :: Bool -> (VersionedTextDocumentIdentifier, T.Text) -> T.Text -> WithDeletions -> WorkspaceEdit+diffText' supports (verTxtDocId, fText) f2Text withDeletions = if supports then WorkspaceEdit Nothing (Just docChanges) Nothing else WorkspaceEdit (Just h) Nothing Nothing where diff = diffTextEdit fText f2Text withDeletions- h = H.singleton f diff- docChanges = J.List [InL docEdit]- docEdit = J.TextDocumentEdit (J.VersionedTextDocumentIdentifier f (Just 0)) $ fmap InL diff+ h = M.singleton (verTxtDocId ^. L.uri) diff+ docChanges = [InL docEdit]+ docEdit = TextDocumentEdit (verTxtDocId ^. re _versionedTextDocumentIdentifier) $ fmap InL diff -- --------------------------------------------------------------------- clientSupportsDocumentChanges :: ClientCapabilities -> Bool clientSupportsDocumentChanges caps =- let ClientCapabilities mwCaps _ _ _ _ = caps+ let ClientCapabilities mwCaps _ _ _ _ _ = caps supports = do wCaps <- mwCaps WorkspaceEditClientCapabilities mDc _ _ _ _ <- _workspaceEdit wCaps mDc- in- Just True == supports+ in Just True == supports -- --------------------------------------------------------------------- @@ -193,11 +202,11 @@ idePluginsToPluginDesc (IdePlugins pp) = pp -- ---------------------------------------------------------------------+ -- | Returns the current client configuration. It is not wise to permanently -- cache the returned value of this function, as clients can at runtime change -- their configuration.----getClientConfig :: MonadLsp Config m => m Config+getClientConfig :: (MonadLsp Config m) => m Config getClientConfig = getConfig -- ---------------------------------------------------------------------@@ -205,10 +214,10 @@ -- | Returns the current plugin configuration. It is not wise to permanently -- cache the returned value of this function, as clients can change their -- configuration at runtime.-getPluginConfig :: MonadLsp Config m => PluginDescriptor c -> m PluginConfig+getPluginConfig :: (MonadLsp Config m) => PluginDescriptor c -> m PluginConfig getPluginConfig plugin = do- config <- getClientConfig- return $ configForPlugin config plugin+ config <- getClientConfig+ return $ configForPlugin config plugin -- --------------------------------------------------------------------- @@ -225,66 +234,79 @@ -- --------------------------------------------------------------------- -extractRange :: Range -> T.Text -> T.Text-extractRange (Range (Position sl _) (Position el _)) s = newS- where focusLines = take (fromIntegral $ el-sl+1) $ drop (fromIntegral sl) $ T.lines s- newS = T.unlines focusLines+-- | Extracts exact matching text in the range.+extractTextInRange :: Range -> T.Text -> T.Text+extractTextInRange (Range (Position sl sc) (Position el ec)) s = newS+ where+ 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+ & _last %~ T.take (fromIntegral ec)+ & _head %~ T.drop (fromIntegral sc)+ -- NOTE: We cannot use unlines here, because we don't want to add trailing newline!+ & T.intercalate "\n" -- | Gets the range that covers the entire text fullRange :: T.Text -> Range fullRange s = Range startPos endPos- where startPos = Position 0 0- endPos = Position lastLine 0- {-- In order to replace everything including newline characters,- the end range should extend below the last line. From the specification:- "If you want to specify a range that contains a line including- the line ending character(s) then use an end position denoting- the start of the next line"- -}- lastLine = fromIntegral $ length $ T.lines s+ where+ startPos = Position 0 0+ endPos = Position lastLine 0+ {-+ In order to replace everything including newline characters,+ the end range should extend below the last line. From the specification:+ "If you want to specify a range that contains a line including+ the line ending character(s) then use an end position denoting+ the start of the next line"+ -}+ lastLine = fromIntegral $ length $ T.lines s 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] allLspCmdIds' pid (IdePlugins ls) =- allLspCmdIds pid $ map (pluginId &&& pluginCommands) ls+ allLspCmdIds pid $ map (pluginId &&& pluginCommands) ls allLspCmdIds :: T.Text -> [(PluginId, [PluginCommand ideState])] -> [T.Text] allLspCmdIds pid commands = concatMap go commands where go (plid, cmds) = map (mkLspCmdId pid plid . commandId) cmds - -- --------------------------------------------------------------------- -getNormalizedFilePath :: Monad m => Uri -> ExceptT String m NormalizedFilePath-getNormalizedFilePath uri = handleMaybe errMsg- $ uriToNormalizedFilePath- $ toNormalizedUri uri- where- errMsg = T.unpack $ "Failed converting " <> getUri uri <> " to NormalizedFilePath" --- ----------------------------------------------------------------------throwPluginError :: Monad m => String -> ExceptT String m b-throwPluginError = throwE--handleMaybe :: Monad m => e -> Maybe b -> ExceptT e m b-handleMaybe msg = maybe (throwE msg) return--handleMaybeM :: Monad m => e -> m (Maybe b) -> ExceptT e m b-handleMaybeM msg act = maybeM (throwE msg) return $ lift act--pluginResponse :: Monad m => ExceptT String m a -> m (Either ResponseError a)-pluginResponse =- fmap (first (\msg -> ResponseError InternalError (fromString msg) Nothing))- . runExceptT---- ---------------------------------------------------------------------- type TextParser = P.Parsec Void T.Text -- | Unescape printable escape sequences within double quotes.@@ -292,9 +314,9 @@ -- display as is. unescape :: T.Text -> T.Text unescape input =- case P.runParser escapedTextParser "inline" input of- Left _ -> input- Right strs -> T.pack strs+ case P.runParser escapedTextParser "inline" input of+ Left _ -> input+ Right strs -> T.pack strs -- | Parser for a string that contains double quotes. Returns unescaped string. escapedTextParser :: TextParser String@@ -305,11 +327,20 @@ stringLiteral :: TextParser String stringLiteral = do- inside <- P.char '"' >> P.manyTill P.charLiteral (P.char '"')- let f '"' = "\\\"" -- double quote should still be escaped- -- Despite the docs, 'showLitChar' and 'showLitString' from 'Data.Char' DOES ESCAPE unicode printable- -- characters. So we need to call 'isPrint' from 'Data.Char' manually.- f ch = if isPrint ch then [ch] else showLitChar ch ""- inside' = concatMap f inside+ inside <- P.char '"' >> P.manyTill P.charLiteral (P.char '"')+ let f '"' = "\\\"" -- double quote should still be escaped+ -- Despite the docs, 'showLitChar' and 'showLitString' from 'Data.Char' DOES ESCAPE unicode printable+ -- characters. So we need to call 'isPrint' from 'Data.Char' manually.+ f ch = if isPrint ch then [ch] else showLitChar ch ""+ inside' = concatMap f inside - pure $ "\"" <> 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,982 +1,1324 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ViewPatterns #-}--module Ide.Types-( PluginDescriptor(..), defaultPluginDescriptor, defaultCabalPluginDescriptor-, defaultPluginPriority-, IdeCommand(..)-, IdeMethod(..)-, IdeNotification(..)-, IdePlugins(IdePlugins, ipMap)-, DynFlagsModifications(..)-, Config(..), PluginConfig(..), CheckParents(..)-, ConfigDescriptor(..), defaultConfigDescriptor, configForPlugin, pluginEnabledConfig-, CustomConfig(..), mkCustomConfig-, FallbackCodeActionParams(..)-, FormattingType(..), FormattingMethod, FormattingHandler, mkFormattingHandlers-, HasTracing(..)-, PluginCommand(..), CommandId(..), CommandFunction, mkLspCommand, mkLspCmdId-, PluginId(..)-, PluginHandler(..), mkPluginHandler-, PluginHandlers(..)-, PluginMethod(..)-, PluginMethodHandler-, PluginNotificationHandler(..), mkPluginNotificationHandler-, PluginNotificationHandlers(..)-, PluginRequestMethod(..)-, getProcessID, getPid-, installSigUsr1Handler-, responseError-, lookupCommandProvider-)- where--#ifdef mingw32_HOST_OS-import qualified System.Win32.Process as P (getCurrentProcessId)-#else-import Control.Monad (void)-import qualified System.Posix.Process as P (getProcessID)-import System.Posix.Signals-#endif-import Control.Applicative ((<|>))-import Control.Arrow ((&&&))-import Control.Lens ((^.), (.~))-import Data.Aeson hiding (defaultOptions)-import Data.Default-import Data.Dependent.Map (DMap)-import qualified Data.Dependent.Map as DMap-import qualified Data.DList as DList-import Data.GADT.Compare-import Data.Hashable (Hashable)-import Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as HashMap-import Data.List.Extra (find, sortOn)-import Data.List.NonEmpty (NonEmpty (..), toList)-import qualified Data.Map as Map-import Data.Maybe-import Data.Ord-import Data.Semigroup-import Data.String-import qualified Data.Text as T-import Data.Text.Encoding (encodeUtf8)-import Development.IDE.Graph-import GHC (DynFlags)-import GHC.Generics-import Ide.Plugin.Properties-import Language.LSP.Server (LspM, getVirtualFile)-import Language.LSP.Types hiding- (SemanticTokenAbsolute (length, line),- SemanticTokenRelative (length),- SemanticTokensEdit (_start))-import Language.LSP.Types.Capabilities (ClientCapabilities (ClientCapabilities),- TextDocumentClientCapabilities (_codeAction, _documentSymbol))-import qualified Language.LSP.Types.Lens as J-import Language.LSP.Types.Lens as J (HasChildren (children),- HasCommand (command),- HasContents (contents),- HasDeprecated (deprecated),- HasEdit (edit),- HasKind (kind),- HasName (name),- HasOptions (..),- HasRange (range),- HasTextDocument (..),- HasTitle (title),- HasUri (..))-import Language.LSP.VFS-import Numeric.Natural-import OpenTelemetry.Eventlog-import Options.Applicative (ParserInfo)-import System.FilePath-import System.IO.Unsafe-import Text.Regex.TDFA.Text ()---- -----------------------------------------------------------------------data IdePlugins ideState = IdePlugins_- { ipMap_ :: HashMap PluginId (PluginDescriptor ideState)- , lookupCommandProvider :: CommandId -> Maybe PluginId- }---- | Smart constructor that deduplicates plugins-pattern IdePlugins :: [PluginDescriptor ideState] -> IdePlugins ideState-pattern IdePlugins{ipMap} <- IdePlugins_ (sortOn (Down . pluginPriority) . HashMap.elems -> ipMap) _- where- IdePlugins ipMap = IdePlugins_{ipMap_ = HashMap.fromList $ (pluginId &&& id) <$> ipMap- , lookupCommandProvider = lookupPluginId ipMap- }-{-# COMPLETE IdePlugins #-}--instance Semigroup (IdePlugins a) where- (IdePlugins_ a f) <> (IdePlugins_ b g) = IdePlugins_ (a <> b) (\x -> f x <|> g x)--instance Monoid (IdePlugins a) where- mempty = IdePlugins_ mempty (const Nothing)---- | Lookup the plugin that exposes a particular command-lookupPluginId :: [PluginDescriptor a] -> CommandId -> Maybe PluginId-lookupPluginId ls cmd = pluginId <$> find go ls- where- go desc = cmd `elem` map commandId (pluginCommands desc)---- | Hooks for modifying the 'DynFlags' at different times of the compilation--- process. Plugins can install a 'DynFlagsModifications' via--- 'pluginModifyDynflags' in their 'PluginDescriptor'.-data DynFlagsModifications =- DynFlagsModifications- { -- | Invoked immediately at the package level. Changes to the 'DynFlags'- -- made in 'dynFlagsModifyGlobal' are guaranteed to be seen everywhere in- -- the compilation pipeline.- dynFlagsModifyGlobal :: DynFlags -> DynFlags- -- | Invoked just before the parsing step, and reset immediately- -- afterwards. 'dynFlagsModifyParser' allows plugins to enable language- -- extensions only during parsing. for example, to let them enable- -- certain pieces of syntax.- , dynFlagsModifyParser :: DynFlags -> DynFlags- }--instance Semigroup DynFlagsModifications where- DynFlagsModifications g1 p1 <> DynFlagsModifications g2 p2 =- DynFlagsModifications (g2 . g1) (p2 . p1)--instance Monoid DynFlagsModifications where- mempty = DynFlagsModifications id id---- -----------------------------------------------------------------------newtype IdeCommand state = IdeCommand (state -> IO ())-instance Show (IdeCommand st) where show _ = "<ide command>"---- ------------------------------------------------------------------------- | We (initially anyway) mirror the hie configuration, so that existing--- clients can simply switch executable and not have any nasty surprises. There--- will be surprises relating to config options being ignored, initially though.-data Config =- Config- { checkParents :: CheckParents- , checkProject :: !Bool- , formattingProvider :: !T.Text- , cabalFormattingProvider :: !T.Text- , maxCompletions :: !Int- , plugins :: !(Map.Map PluginId PluginConfig)- } deriving (Show,Eq)--instance ToJSON Config where- toJSON Config{..} =- object [ "haskell" .= r ]- where- r = object [ "checkParents" .= checkParents- , "checkProject" .= checkProject- , "formattingProvider" .= formattingProvider- , "maxCompletions" .= maxCompletions- , "plugin" .= Map.mapKeysMonotonic (\(PluginId p) -> p) plugins- ]--instance Default Config where- def = Config- { checkParents = CheckOnSave- , checkProject = True- -- , formattingProvider = "brittany"- , formattingProvider = "ormolu"- -- , formattingProvider = "floskell"- -- , formattingProvider = "stylish-haskell"- , cabalFormattingProvider = "cabal-fmt"- , maxCompletions = 40- , plugins = mempty- }--data CheckParents- -- Note that ordering of constructors is meaningful and must be monotonically- -- increasing in the scenarios where parents are checked- = NeverCheck- | CheckOnSave- | AlwaysCheck- deriving stock (Eq, Ord, Show, Generic)- deriving anyclass (FromJSON, ToJSON)---- | A PluginConfig is a generic configuration for a given HLS plugin. It--- provides a "big switch" to turn it on or off as a whole, as well as small--- switches per feature, and a slot for custom config.--- This provides a regular naming scheme for all plugin config.-data PluginConfig =- PluginConfig- { plcGlobalOn :: !Bool- , plcCallHierarchyOn :: !Bool- , plcCodeActionsOn :: !Bool- , plcCodeLensOn :: !Bool- , plcDiagnosticsOn :: !Bool- , plcHoverOn :: !Bool- , plcSymbolsOn :: !Bool- , plcCompletionOn :: !Bool- , plcRenameOn :: !Bool- , plcSelectionRangeOn :: !Bool- , plcFoldingRangeOn :: !Bool- , plcConfig :: !Object- } deriving (Show,Eq)--instance Default PluginConfig where- def = PluginConfig- { plcGlobalOn = True- , plcCallHierarchyOn = True- , plcCodeActionsOn = True- , plcCodeLensOn = True- , plcDiagnosticsOn = True- , plcHoverOn = True- , plcSymbolsOn = True- , plcCompletionOn = True- , plcRenameOn = True- , plcSelectionRangeOn = True- , plcFoldingRangeOn = True- , plcConfig = mempty- }--instance ToJSON PluginConfig where- toJSON (PluginConfig g ch ca cl d h s c rn sr fr cfg) = r- where- r = object [ "globalOn" .= g- , "callHierarchyOn" .= ch- , "codeActionsOn" .= ca- , "codeLensOn" .= cl- , "diagnosticsOn" .= d- , "hoverOn" .= h- , "symbolsOn" .= s- , "completionOn" .= c- , "renameOn" .= rn- , "selectionRangeOn" .= sr- , "foldingRangeOn" .= fr- , "config" .= cfg- ]---- -----------------------------------------------------------------------data PluginDescriptor (ideState :: *) =- PluginDescriptor { pluginId :: !PluginId- -- ^ Unique identifier of the plugin.- , pluginPriority :: Natural- -- ^ Plugin handlers are called in priority order, higher priority first- , pluginRules :: !(Rules ())- , pluginCommands :: ![PluginCommand ideState]- , pluginHandlers :: PluginHandlers ideState- , pluginConfigDescriptor :: ConfigDescriptor- , pluginNotificationHandlers :: PluginNotificationHandlers ideState- , pluginModifyDynflags :: DynFlagsModifications- , pluginCli :: Maybe (ParserInfo (IdeCommand ideState))- , pluginFileType :: [T.Text]- -- ^ 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---- | An existential wrapper of 'Properties'-data CustomConfig = forall r. CustomConfig (Properties r)---- | Describes the configuration a plugin.--- A plugin may be configurable in such form:------ @--- {--- "plugin-id": {--- "globalOn": true,--- "codeActionsOn": true,--- "codeLensOn": true,--- "config": {--- "property1": "foo"--- }--- }--- }--- @------ @globalOn@, @codeActionsOn@, and @codeLensOn@ etc. are called generic configs,--- which can be inferred from handlers registered by the plugin.--- @config@ is called custom config, which is defined using 'Properties'.-data ConfigDescriptor = ConfigDescriptor {- -- | Initial values for the generic config- configInitialGenericConfig :: PluginConfig,- -- | Whether or not to generate @diagnosticsOn@ config.- -- Diagnostics emit in arbitrary shake rules,- -- so we can't know statically if the plugin produces diagnostics- configHasDiagnostics :: Bool,- -- | Custom config.- configCustomConfig :: CustomConfig-}--mkCustomConfig :: Properties r -> CustomConfig-mkCustomConfig = CustomConfig--defaultConfigDescriptor :: ConfigDescriptor-defaultConfigDescriptor =- ConfigDescriptor Data.Default.def False (mkCustomConfig emptyProperties)---- | 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 :: MethodType) (m :: Method FromClient k) where-- -- | Parse the configuration to check if this plugin is enabled.- -- Perform sanity checks on the message to see whether 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.- --- -- Semantically, this method described 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, but doesn't have to. There are requests- -- with no associated URI that, consequentially, can't inspect the URI.- --- -- Common reason why a plugin might not be allowed to respond although it is enabled:- -- * Plugin can not handle requests associated to the specific URI- -- * Since the implementation of [cabal plugins](https://github.com/haskell/haskell-language-server/issues/2940)- -- HLS knows plugins specific for Haskell and specific for [Cabal file descriptions](https://cabal.readthedocs.io/en/3.6/cabal-package.html)- --- -- Strictly speaking, we are conflating two concepts here:- -- * Dynamically enabled (e.g. enabled on a per-message basis)- -- * Statically enabled (e.g. by configuration in the lsp-client)- -- * Strictly speaking, this might also change dynamically- --- -- But there is no use to split it up currently into two different methods for now.- pluginEnabled- :: SMethod m- -- ^ Method type.- -> MessageParams m- -- ^ Whether a plugin is enabled might depend on the message parameters- -- eg 'pluginFileType' specifies what file extension a plugin is allowed to handle- -> PluginDescriptor c- -- ^ Contains meta information such as PluginId and what file types this- -- plugin is able to handle.- -> Config- -- ^ Generic config description, expected to hold 'PluginConfig' configuration- -- for this plugin- -> Bool- -- ^ Is this plugin enabled and allowed to respond to the given request- -- with the given parameters?-- default pluginEnabled :: (HasTextDocument (MessageParams m) doc, 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 ^. J.textDocument . J.uri---- ------------------------------------------------------------------------ Plugin Requests--- -----------------------------------------------------------------------class PluginMethod Request m => PluginRequestMethod (m :: Method FromClient 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 allow here to define how to merge two hover request responses into one- -- glorious hover box.- --- -- However, 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 (ResponseResult m) -> ResponseResult m-- default combineResponses :: Semigroup (ResponseResult m)- => SMethod m -> Config -> ClientCapabilities -> MessageParams m -> NonEmpty (ResponseResult m) -> ResponseResult m- combineResponses _method _config _caps _params = sconcat--instance PluginMethod Request TextDocumentCodeAction where- pluginEnabled _ msgParams pluginDesc config =- pluginResponsible uri pluginDesc && pluginEnabledConfig plcCodeActionsOn (configForPlugin config pluginDesc)- where- uri = msgParams ^. J.textDocument . J.uri--instance PluginRequestMethod TextDocumentCodeAction where- combineResponses _method _config (ClientCapabilities _ textDocCaps _ _ _) (CodeActionParams _ _ _ _ context) resps =- fmap compat $ List $ filter wasRequested $ (\(List x) -> x) $ sconcat resps- where- compat :: (Command |? CodeAction) -> (Command |? CodeAction)- compat x@(InL _) = x- compat x@(InR action)- | Just _ <- textDocCaps >>= _codeAction >>= _codeActionLiteralSupport- = x- | otherwise = InL cmd- where- cmd = mkLspCommand "hls" "fallbackCodeAction" (action ^. title) (Just cmdParams)- cmdParams = [toJSON (FallbackCodeActionParams (action ^. edit) (action ^. command))]-- wasRequested :: (Command |? CodeAction) -> Bool- wasRequested (InL _) = True- wasRequested (InR ca)- | Nothing <- _only context = True- | Just (List allowed) <- _only context- -- See https://github.com/microsoft/language-server-protocol/issues/970- -- This is somewhat vague, but due to the hierarchical nature of action kinds, we- -- 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 ^. kind = any (\k -> k `codeActionKindSubsumes` caKind) allowed- | otherwise = False--instance PluginMethod Request TextDocumentDefinition where- pluginEnabled _ msgParams pluginDesc _ =- pluginResponsible uri pluginDesc- where- uri = msgParams ^. J.textDocument . J.uri--instance PluginMethod Request TextDocumentTypeDefinition where- pluginEnabled _ msgParams pluginDesc _ =- pluginResponsible uri pluginDesc- where- uri = msgParams ^. J.textDocument . J.uri--instance PluginMethod Request TextDocumentDocumentHighlight where- pluginEnabled _ msgParams pluginDesc _ =- pluginResponsible uri pluginDesc- where- uri = msgParams ^. J.textDocument . J.uri--instance PluginMethod Request TextDocumentReferences where- pluginEnabled _ msgParams pluginDesc _ =- pluginResponsible uri pluginDesc- where- uri = msgParams ^. J.textDocument . J.uri--instance PluginMethod Request WorkspaceSymbol where- -- Unconditionally enabled, but should it really be?- pluginEnabled _ _ _ _ = True--instance PluginMethod Request TextDocumentCodeLens where- pluginEnabled _ msgParams pluginDesc config = pluginResponsible uri pluginDesc- && pluginEnabledConfig plcCodeLensOn (configForPlugin config pluginDesc)- where- uri = msgParams ^. J.textDocument . J.uri--instance PluginMethod Request TextDocumentRename where- pluginEnabled _ msgParams pluginDesc config = pluginResponsible uri pluginDesc- && pluginEnabledConfig plcRenameOn (configForPlugin config pluginDesc)- where- uri = msgParams ^. J.textDocument . J.uri-instance PluginMethod Request TextDocumentHover where- pluginEnabled _ msgParams pluginDesc config = pluginResponsible uri pluginDesc- && pluginEnabledConfig plcHoverOn (configForPlugin config pluginDesc)- where- uri = msgParams ^. J.textDocument . J.uri--instance PluginMethod Request TextDocumentDocumentSymbol where- pluginEnabled _ msgParams pluginDesc config = pluginResponsible uri pluginDesc- && pluginEnabledConfig plcSymbolsOn (configForPlugin config pluginDesc)- where- uri = msgParams ^. J.textDocument . J.uri--instance PluginMethod Request CompletionItemResolve where- pluginEnabled _ msgParams pluginDesc config = pluginEnabledConfig plcCompletionOn (configForPlugin config pluginDesc)--instance PluginMethod Request TextDocumentCompletion where- pluginEnabled _ msgParams pluginDesc config = pluginResponsible uri pluginDesc- && pluginEnabledConfig plcCompletionOn (configForPlugin config pluginDesc)- where- uri = msgParams ^. J.textDocument . J.uri--instance PluginMethod Request TextDocumentFormatting where- pluginEnabled STextDocumentFormatting msgParams pluginDesc conf =- pluginResponsible uri pluginDesc- && (PluginId (formattingProvider conf) == pid || PluginId (cabalFormattingProvider conf) == pid)- where- uri = msgParams ^. J.textDocument . J.uri- pid = pluginId pluginDesc--instance PluginMethod Request TextDocumentRangeFormatting where- pluginEnabled _ msgParams pluginDesc conf = pluginResponsible uri pluginDesc- && (PluginId (formattingProvider conf) == pid || PluginId (cabalFormattingProvider conf) == pid)- where- uri = msgParams ^. J.textDocument . J.uri- pid = pluginId pluginDesc--instance PluginMethod Request TextDocumentPrepareCallHierarchy where- pluginEnabled _ msgParams pluginDesc conf = pluginResponsible uri pluginDesc- && pluginEnabledConfig plcCallHierarchyOn (configForPlugin conf pluginDesc)- where- uri = msgParams ^. J.textDocument . J.uri--instance PluginMethod Request TextDocumentSelectionRange where- pluginEnabled _ msgParams pluginDesc conf = pluginResponsible uri pluginDesc- && pluginEnabledConfig plcSelectionRangeOn (configForPlugin conf pluginDesc)- where- uri = msgParams ^. J.textDocument . J.uri--instance PluginMethod Request TextDocumentFoldingRange where- pluginEnabled _ msgParams pluginDesc conf = pluginResponsible uri pluginDesc- && pluginEnabledConfig plcFoldingRangeOn (configForPlugin conf pluginDesc)- where- uri = msgParams ^. J.textDocument . J.uri--instance PluginMethod Request CallHierarchyIncomingCalls where- -- This method has no URI parameter, thus no call to 'pluginResponsible'- pluginEnabled _ _ pluginDesc conf = pluginEnabledConfig plcCallHierarchyOn (configForPlugin conf pluginDesc)--instance PluginMethod Request CallHierarchyOutgoingCalls where- -- This method has no URI parameter, thus no call to 'pluginResponsible'- pluginEnabled _ _ pluginDesc conf = pluginEnabledConfig plcCallHierarchyOn (configForPlugin conf pluginDesc)--instance PluginMethod Request CustomMethod where- pluginEnabled _ _ _ _ = True------instance PluginRequestMethod TextDocumentDefinition where- combineResponses _ _ _ _ (x :| _) = x--instance PluginRequestMethod TextDocumentTypeDefinition where- combineResponses _ _ _ _ (x :| _) = x--instance PluginRequestMethod TextDocumentDocumentHighlight where--instance PluginRequestMethod TextDocumentReferences where--instance PluginRequestMethod WorkspaceSymbol where--instance PluginRequestMethod TextDocumentCodeLens where--instance PluginRequestMethod TextDocumentRename where--instance PluginRequestMethod TextDocumentHover where- combineResponses _ _ _ _ (catMaybes . toList -> hs) = h- where- r = listToMaybe $ mapMaybe (^. range) hs- h = case foldMap (^. contents) hs of- HoverContentsMS (List []) -> Nothing- hh -> Just $ Hover hh r--instance PluginRequestMethod TextDocumentDocumentSymbol where- combineResponses _ _ (ClientCapabilities _ tdc _ _ _) params xs = res- where- uri' = params ^. textDocument . uri- supportsHierarchy = Just True == (tdc >>= _documentSymbol >>= _hierarchicalDocumentSymbolSupport)- dsOrSi = fmap toEither xs- res- | supportsHierarchy = InL $ sconcat $ fmap (either id (fmap siToDs)) dsOrSi- | otherwise = InR $ sconcat $ fmap (either (List . concatMap dsToSi) id) dsOrSi- siToDs (SymbolInformation name kind _tags dep (Location _uri range) cont)- = DocumentSymbol name cont kind Nothing dep range range Nothing- dsToSi = go Nothing- go :: Maybe T.Text -> DocumentSymbol -> [SymbolInformation]- go parent ds =- let children' :: [SymbolInformation]- children' = concatMap (go (Just name')) (fromMaybe mempty (ds ^. children))- loc = Location uri' (ds ^. range)- name' = ds ^. name- si = SymbolInformation name' (ds ^. kind) Nothing (ds ^. deprecated) loc parent- in [si] <> children'--instance PluginRequestMethod CompletionItemResolve where- -- resolving completions can only change the detail, additionalTextEdit or documentation fields- combineResponses _ _ _ _ (x :| xs) = go x xs- where go :: CompletionItem -> [CompletionItem] -> CompletionItem- go !comp [] = comp- go !comp1 (comp2:xs)- = go (comp1- & J.detail .~ comp1 ^. J.detail <> comp2 ^. J.detail- & J.documentation .~ ((comp1 ^. J.documentation) <|> (comp2 ^. J.documentation)) -- difficult to write generic concatentation for docs- & J.additionalTextEdits .~ comp1 ^. J.additionalTextEdits <> comp2 ^. J.additionalTextEdits)- xs--instance PluginRequestMethod TextDocumentCompletion where- combineResponses _ conf _ _ (toList -> xs) = snd $ consumeCompletionResponse limit $ combine xs- where- limit = maxCompletions conf- combine :: [List CompletionItem |? CompletionList] -> (List CompletionItem |? CompletionList)- combine cs = go True mempty cs-- go !comp acc [] =- InR (CompletionList comp (List $ DList.toList acc))- go comp acc (InL (List ls) : rest) =- go comp (acc <> DList.fromList ls) rest- go comp acc (InR (CompletionList comp' (List ls)) : rest) =- go (comp && comp') (acc <> DList.fromList ls) rest-- -- boolean disambiguators- isCompleteResponse, isIncompleteResponse :: Bool- isIncompleteResponse = True- isCompleteResponse = False-- consumeCompletionResponse limit it@(InR (CompletionList _ (List xx))) =- case splitAt limit xx of- -- consumed all the items, return the result as is- (_, []) -> (limit - length xx, it)- -- need to crop the response, set the 'isIncomplete' flag- (xx', _) -> (0, InR (CompletionList isIncompleteResponse (List xx')))- consumeCompletionResponse n (InL (List xx)) =- consumeCompletionResponse n (InR (CompletionList isCompleteResponse (List xx)))--instance PluginRequestMethod TextDocumentFormatting where- combineResponses _ _ _ _ (x :| _) = x--instance PluginRequestMethod TextDocumentRangeFormatting where- combineResponses _ _ _ _ (x :| _) = x--instance PluginRequestMethod TextDocumentPrepareCallHierarchy where--instance PluginRequestMethod TextDocumentSelectionRange where- combineResponses _ _ _ _ (x :| _) = x--instance PluginRequestMethod TextDocumentFoldingRange where- combineResponses _ _ _ _ x = sconcat x--instance PluginRequestMethod CallHierarchyIncomingCalls where--instance PluginRequestMethod CallHierarchyOutgoingCalls where--instance PluginRequestMethod CustomMethod where- combineResponses _ _ _ _ (x :| _) = x---- ------------------------------------------------------------------------ Plugin Notifications--- ------------------------------------------------------------------------- | Plugin Notification methods. No specific methods at the moment, but--- might contain more in the future.-class PluginMethod Notification m => PluginNotificationMethod (m :: Method FromClient Notification) where---instance PluginMethod Notification TextDocumentDidOpen where--instance PluginMethod Notification TextDocumentDidChange where--instance PluginMethod Notification TextDocumentDidSave where--instance PluginMethod Notification TextDocumentDidClose where--instance PluginMethod Notification WorkspaceDidChangeWatchedFiles where- -- This method has no URI parameter, thus no call to 'pluginResponsible'.- pluginEnabled _ _ desc conf = plcGlobalOn $ configForPlugin conf desc--instance PluginMethod Notification WorkspaceDidChangeWorkspaceFolders where- -- This method has no URI parameter, thus no call to 'pluginResponsible'.- pluginEnabled _ _ desc conf = plcGlobalOn $ configForPlugin conf desc--instance PluginMethod Notification WorkspaceDidChangeConfiguration where- -- This method has no URI parameter, thus no call to 'pluginResponsible'.- pluginEnabled _ _ desc conf = plcGlobalOn $ configForPlugin conf desc--instance PluginMethod Notification Initialized where- -- This method has no URI parameter, thus no call to 'pluginResponsible'.- pluginEnabled _ _ desc conf = plcGlobalOn $ configForPlugin conf desc---instance PluginNotificationMethod TextDocumentDidOpen where--instance PluginNotificationMethod TextDocumentDidChange where--instance PluginNotificationMethod TextDocumentDidSave where--instance PluginNotificationMethod TextDocumentDidClose where--instance PluginNotificationMethod WorkspaceDidChangeWatchedFiles where--instance PluginNotificationMethod WorkspaceDidChangeWorkspaceFolders where--instance PluginNotificationMethod WorkspaceDidChangeConfiguration where--instance PluginNotificationMethod Initialized where---- ------------------------------------------------------------------------- | Methods which have a PluginMethod instance-data IdeMethod (m :: Method FromClient Request) = PluginRequestMethod m => IdeMethod (SMethod m)-instance GEq IdeMethod where- geq (IdeMethod a) (IdeMethod b) = geq a b-instance GCompare IdeMethod where- gcompare (IdeMethod a) (IdeMethod b) = gcompare a b---- | Methods which have a PluginMethod instance-data IdeNotification (m :: Method FromClient Notification) = PluginNotificationMethod m => IdeNotification (SMethod m)-instance GEq IdeNotification where- geq (IdeNotification a) (IdeNotification b) = geq a b-instance GCompare IdeNotification where- gcompare (IdeNotification a) (IdeNotification b) = gcompare a b---- | Combine handlers for the-newtype PluginHandler a (m :: Method FromClient Request)- = PluginHandler (PluginId -> a -> MessageParams m -> LspM Config (NonEmpty (Either ResponseError (ResponseResult m))))--newtype PluginNotificationHandler a (m :: Method FromClient Notification)- = PluginNotificationHandler (PluginId -> a -> VFS -> MessageParams m -> LspM Config ())--newtype PluginHandlers a = PluginHandlers (DMap IdeMethod (PluginHandler a))-newtype PluginNotificationHandlers a = PluginNotificationHandlers (DMap IdeNotification (PluginNotificationHandler a))-instance Semigroup (PluginHandlers a) where- (PluginHandlers a) <> (PluginHandlers b) = PluginHandlers $ DMap.unionWithKey go a b- where- go _ (PluginHandler f) (PluginHandler g) = PluginHandler $ \pid ide params ->- (<>) <$> f pid ide params <*> g pid ide params--instance Monoid (PluginHandlers a) where- mempty = PluginHandlers mempty--instance Semigroup (PluginNotificationHandlers a) where- (PluginNotificationHandlers a) <> (PluginNotificationHandlers b) = PluginNotificationHandlers $ DMap.unionWithKey go a b- where- go _ (PluginNotificationHandler f) (PluginNotificationHandler g) = PluginNotificationHandler $ \pid ide vfs params ->- f pid ide vfs params >> g pid ide vfs params--instance Monoid (PluginNotificationHandlers a) where- mempty = PluginNotificationHandlers mempty--type PluginMethodHandler a m = a -> PluginId -> MessageParams m -> LspM Config (Either ResponseError (ResponseResult m))--type PluginNotificationMethodHandler a m = a -> VFS -> PluginId -> MessageParams m -> LspM Config ()---- | Make a handler for plugins with no extra data-mkPluginHandler- :: PluginRequestMethod m- => SClientMethod m- -> PluginMethodHandler ideState m- -> PluginHandlers ideState-mkPluginHandler m f = PluginHandlers $ DMap.singleton (IdeMethod m) (PluginHandler f')- where- f' pid ide params = pure <$> f ide pid params---- | Make a handler for plugins with no extra data-mkPluginNotificationHandler- :: PluginNotificationMethod m- => SClientMethod (m :: Method FromClient Notification)- -> PluginNotificationMethodHandler ideState m- -> PluginNotificationHandlers ideState-mkPluginNotificationHandler m f- = PluginNotificationHandlers $ DMap.singleton (IdeNotification m) (PluginNotificationHandler f')- where- f' pid ide vfs = f ide vfs pid--defaultPluginPriority :: Natural-defaultPluginPriority = 1000---- | Set up a plugin descriptor, initialized with default values.--- This is plugin descriptor is prepared for @haskell@ files, such as------ * @.hs@--- * @.lhs@--- * @.hs-boot@------ and handlers will be enabled for files with the appropriate file--- extensions.-defaultPluginDescriptor :: PluginId -> PluginDescriptor ideState-defaultPluginDescriptor plId =- PluginDescriptor- plId- defaultPluginPriority- mempty- mempty- mempty- defaultConfigDescriptor- mempty- mempty- Nothing- [".hs", ".lhs", ".hs-boot"]---- | Set up a plugin descriptor, initialized with default values.--- This is plugin descriptor is prepared for @.cabal@ files and as such,--- will only respond / run when @.cabal@ files are currently in scope.------ Handles files with the following extensions:--- * @.cabal@-defaultCabalPluginDescriptor :: PluginId -> PluginDescriptor ideState-defaultCabalPluginDescriptor plId =- PluginDescriptor- plId- defaultPluginPriority- mempty- mempty- mempty- defaultConfigDescriptor- mempty- mempty- Nothing- [".cabal"]--newtype CommandId = CommandId T.Text- deriving (Show, Read, Eq, Ord)-instance IsString CommandId where- fromString = CommandId . T.pack--data PluginCommand ideState = forall a. (FromJSON a) =>- PluginCommand { commandId :: CommandId- , commandDesc :: T.Text- , commandFunc :: CommandFunction ideState a- }---- -----------------------------------------------------------------------type CommandFunction ideState a- = ideState- -> a- -> LspM Config (Either ResponseError Value)---- -----------------------------------------------------------------------newtype PluginId = PluginId T.Text- deriving (Show, Read, Eq, Ord)- deriving newtype (FromJSON, Hashable)--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.--- Range must be relative to the text to format.--- To format the whole document, read the Text from the file and use 'FormatText'--- as the FormattingType.-data FormattingType = FormatText- | FormatRange Range---type FormattingMethod m =- ( J.HasOptions (MessageParams m) FormattingOptions- , J.HasTextDocument (MessageParams m) TextDocumentIdentifier- , ResponseResult m ~ List TextEdit- )--type FormattingHandler a- = a- -> FormattingType- -> T.Text- -> NormalizedFilePath- -> FormattingOptions- -> LspM Config (Either ResponseError (List TextEdit))--mkFormattingHandlers :: forall a. FormattingHandler a -> PluginHandlers a-mkFormattingHandlers f = mkPluginHandler STextDocumentFormatting (provider STextDocumentFormatting)- <> mkPluginHandler STextDocumentRangeFormatting (provider STextDocumentRangeFormatting)- where- provider :: forall m. FormattingMethod m => SMethod m -> PluginMethodHandler a m- provider m ide _pid params- | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = do- mf <- getVirtualFile $ toNormalizedUri uri- case mf of- Just vf -> do- let typ = case m of- STextDocumentFormatting -> FormatText- STextDocumentRangeFormatting -> FormatRange (params ^. J.range)- _ -> error "mkFormattingHandlers: impossible"- f ide typ (virtualFileText vf) nfp opts- Nothing -> pure $ Left $ responseError $ T.pack $ "Formatter plugin: could not get file contents for " ++ show uri-- | otherwise = pure $ Left $ responseError $ T.pack $ "Formatter plugin: uriToFilePath failed for: " ++ show uri- where- uri = params ^. J.textDocument . J.uri- opts = params ^. J.options---- -----------------------------------------------------------------------responseError :: T.Text -> ResponseError-responseError txt = ResponseError InvalidParams txt Nothing---- -----------------------------------------------------------------------data FallbackCodeActionParams =- FallbackCodeActionParams- { fallbackWorkspaceEdit :: Maybe WorkspaceEdit- , fallbackCommand :: Maybe Command- }- deriving (Generic, ToJSON, FromJSON)---- -----------------------------------------------------------------------otSetUri :: SpanInFlight -> Uri -> IO ()-otSetUri sp (Uri t) = setTag sp "uri" (encodeUtf8 t)--class HasTracing a where- traceWithSpan :: SpanInFlight -> a -> IO ()- traceWithSpan _ _ = pure ()--instance {-# OVERLAPPABLE #-} (HasTextDocument a doc, HasUri doc Uri) => HasTracing a where- traceWithSpan sp a = otSetUri sp (a ^. J.textDocument . J.uri)--instance HasTracing Value-instance HasTracing ExecuteCommandParams-instance HasTracing DidChangeWatchedFilesParams where- traceWithSpan sp DidChangeWatchedFilesParams{_changes} =- setTag sp "changes" (encodeUtf8 $ fromString $ show _changes)-instance HasTracing DidChangeWorkspaceFoldersParams-instance HasTracing DidChangeConfigurationParams-instance HasTracing InitializeParams-instance HasTracing (Maybe InitializedParams)-instance HasTracing WorkspaceSymbolParams where- traceWithSpan sp (WorkspaceSymbolParams _ _ query) = setTag sp "query" (encodeUtf8 query)-instance HasTracing CallHierarchyIncomingCallsParams-instance HasTracing CallHierarchyOutgoingCallsParams-instance HasTracing CompletionItem---- -----------------------------------------------------------------------{-# NOINLINE pROCESS_ID #-}-pROCESS_ID :: T.Text-pROCESS_ID = unsafePerformIO getPid--mkLspCommand :: PluginId -> CommandId -> T.Text -> Maybe [Value] -> Command-mkLspCommand plid cn title args' = Command title cmdId args- where- cmdId = mkLspCmdId pROCESS_ID plid cn- args = List <$> args'--mkLspCmdId :: T.Text -> PluginId -> CommandId -> T.Text-mkLspCmdId pid (PluginId plid) (CommandId cid)- = pid <> ":" <> plid <> ":" <> cid---- | Get the operating system process id for the running server--- instance. This should be the same for the lifetime of the instance,--- and different from that of any other currently running instance.-getPid :: IO T.Text-getPid = T.pack . show <$> getProcessID--getProcessID :: IO Int-installSigUsr1Handler :: IO () -> IO ()--#ifdef mingw32_HOST_OS-getProcessID = fromIntegral <$> P.getCurrentProcessId-installSigUsr1Handler _ = return ()--#else-getProcessID = fromIntegral <$> P.getProcessID--installSigUsr1Handler h = void $ installHandler sigUSR1 (Catch h) Nothing-#endif+{-# LANGUAGE 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(..), SessionLoadingPreferenceConfig(..)+, ConfigDescriptor(..), defaultConfigDescriptor, configForPlugin+, CustomConfig(..), mkCustomConfig+, FallbackCodeActionParams(..)+, FormattingType(..), FormattingMethod, FormattingHandler+, HasTracing(..)+, PluginCommand(..), CommandId(..), CommandFunction, mkLspCommand, mkLspCmdId+, PluginId(..)+, PluginHandler(..), mkPluginHandler+, HandlerM, runHandlerM, pluginGetClientCapabilities, pluginSendNotification, pluginSendRequest, pluginWithIndefiniteProgress+, PluginHandlers(..)+, PluginMethod(..)+, PluginMethodHandler+, PluginNotificationHandler(..), mkPluginNotificationHandler+, PluginNotificationHandlers(..)+, PluginRequestMethod(..)+, getProcessID, getPid+, getVirtualFileFromVFS+, installSigUsr1Handler+, lookupCommandProvider+, ResolveFunction+, mkResolveHandler+)+ where++#ifdef mingw32_HOST_OS++import qualified System.Win32.Process as P (getCurrentProcessId)++#else++import qualified System.Posix.Process as P (getProcessID)+import System.Posix.Signals++#endif++import Control.Applicative ((<|>))+import Control.Arrow ((&&&))+import Control.Lens (_Just, view, (.~), (?~), (^.),+ (^?))+import Control.Monad (void)+import Control.Monad.Error.Class (MonadError (throwError))+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+import qualified Data.DList as DList+import Data.GADT.Compare+import Data.Hashable (Hashable)+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import Data.Kind (Type)+import Data.List.Extra (find, sortOn)+import Data.List.NonEmpty (NonEmpty (..), toList)+import qualified Data.Map as Map+import Data.Maybe+import Data.Ord+import Data.Semigroup+import Data.String+import qualified Data.Text as T+import Data.Text.Encoding (encodeUtf8)+import Development.IDE.Graph+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 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 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_+ { ipMap_ :: HashMap PluginId (PluginDescriptor ideState)+ , lookupCommandProvider :: CommandId -> Maybe PluginId+ }++-- | Smart constructor that deduplicates plugins+pattern IdePlugins :: [PluginDescriptor ideState] -> IdePlugins ideState+pattern IdePlugins{ipMap} <- IdePlugins_ (sortOn (Down . pluginPriority) . HashMap.elems -> ipMap) _+ where+ IdePlugins ipMap = IdePlugins_{ipMap_ = HashMap.fromList $ (pluginId &&& id) <$> ipMap+ , lookupCommandProvider = lookupPluginId ipMap+ }+{-# COMPLETE IdePlugins #-}++instance Semigroup (IdePlugins a) where+ (IdePlugins_ a f) <> (IdePlugins_ b g) = IdePlugins_ (a <> b) (\x -> f x <|> g x)++instance Monoid (IdePlugins a) where+ mempty = IdePlugins_ mempty (const Nothing)++-- | Lookup the plugin that exposes a particular command+lookupPluginId :: [PluginDescriptor a] -> CommandId -> Maybe PluginId+lookupPluginId ls cmd = pluginId <$> find go ls+ where+ go desc = cmd `elem` map commandId (pluginCommands desc)++-- | Hooks for modifying the 'DynFlags' at different times of the compilation+-- process. Plugins can install a 'DynFlagsModifications' via+-- 'pluginModifyDynflags' in their 'PluginDescriptor'.+data DynFlagsModifications =+ DynFlagsModifications+ { -- | Invoked immediately at the package level. Changes to the 'DynFlags'+ -- made in 'dynFlagsModifyGlobal' are guaranteed to be seen everywhere in+ -- the compilation pipeline.+ dynFlagsModifyGlobal :: DynFlags -> DynFlags+ -- | Invoked just before the parsing step, and reset immediately+ -- afterwards. 'dynFlagsModifyParser' allows plugins to enable language+ -- extensions only during parsing. for example, to let them enable+ -- certain pieces of syntax.+ , dynFlagsModifyParser :: DynFlags -> DynFlags+ }++instance Semigroup DynFlagsModifications where+ DynFlagsModifications g1 p1 <> DynFlagsModifications g2 p2 =+ DynFlagsModifications (g2 . g1) (p2 . p1)++instance Monoid DynFlagsModifications where+ mempty = DynFlagsModifications id id++-- ---------------------------------------------------------------------++newtype IdeCommand state = IdeCommand (state -> IO ())+instance Show (IdeCommand st) where show _ = "<ide command>"++-- ---------------------------------------------------------------------++-- | We (initially anyway) mirror the hie configuration, so that existing+-- clients can simply switch executable and not have any nasty surprises. There+-- will initially be surprises relating to config options being ignored though.+data Config =+ Config+ { checkParents :: CheckParents+ , checkProject :: !Bool+ , formattingProvider :: !T.Text+ , cabalFormattingProvider :: !T.Text+ , maxCompletions :: !Int+ , sessionLoading :: !SessionLoadingPreferenceConfig+ , plugins :: !(Map.Map PluginId PluginConfig)+ } deriving (Show,Eq)++instance ToJSON Config where+ toJSON Config{..} =+ object [ "checkParents" .= checkParents+ , "checkProject" .= checkProject+ , "formattingProvider" .= formattingProvider+ , "cabalFormattingProvider" .= cabalFormattingProvider+ , "maxCompletions" .= maxCompletions+ , "sessionLoading" .= sessionLoading+ , "plugin" .= Map.mapKeysMonotonic (\(PluginId p) -> p) plugins+ ]++instance Default Config where+ def = Config+ { checkParents = CheckOnSave+ , checkProject = True+ , formattingProvider = "ormolu"+ -- , formattingProvider = "stylish-haskell"+ , 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+ }++data CheckParents+ -- Note that ordering of constructors is meaningful and must be monotonically+ -- increasing in the scenarios where parents are checked+ = NeverCheck+ | CheckOnSave+ | AlwaysCheck+ 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.+-- This provides a regular naming scheme for all plugin config.+data PluginConfig =+ PluginConfig+ { plcGlobalOn :: !Bool+ , 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)++instance Default PluginConfig where+ def = PluginConfig+ { plcGlobalOn = True+ , plcCallHierarchyOn = True+ , plcCodeActionsOn = True+ , plcCodeLensOn = True+ , plcInlayHintsOn = True+ , plcDiagnosticsOn = True+ , plcHoverOn = True+ , plcSymbolsOn = True+ , plcSignatureHelpOn = True+ , plcCompletionOn = True+ , plcRenameOn = True+ , plcSelectionRangeOn = True+ , plcFoldingRangeOn = True+ , plcSemanticTokensOn = True+ , plcConfig = mempty+ }++instance ToJSON PluginConfig where+ 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+ ]++-- ---------------------------------------------------------------------++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+ , pluginRules :: !(Rules ())+ , pluginCommands :: ![PluginCommand ideState]+ , pluginHandlers :: PluginHandlers ideState+ , pluginConfigDescriptor :: ConfigDescriptor+ , pluginNotificationHandlers :: PluginNotificationHandlers ideState+ , pluginModifyDynflags :: DynFlagsModifications+ , pluginCli :: Maybe (ParserInfo (IdeCommand ideState))+ , 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 '.'.+ }++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)++-- | Describes the configuration of a plugin.+-- A plugin may be configurable as can be seen below:+--+-- @+-- {+-- "plugin-id": {+-- "globalOn": true,+-- "codeActionsOn": true,+-- "codeLensOn": true,+-- "config": {+-- "property1": "foo"+-- }+-- }+-- }+-- @+--+-- @globalOn@, @codeActionsOn@, and @codeLensOn@ etc. are called generic configs+-- which can be inferred from handlers registered by the plugin.+-- @config@ is called custom config, which is defined using 'Properties'.+data ConfigDescriptor = ConfigDescriptor {+ -- | Initial values for the generic config+ configInitialGenericConfig :: PluginConfig,+ -- | Whether or not to generate @diagnosticsOn@ config.+ -- Diagnostics emit in arbitrary shake rules,+ -- so we can't know statically if the plugin produces diagnostics+ configHasDiagnostics :: Bool,+ -- | Custom config.+ configCustomConfig :: CustomConfig+}++mkCustomConfig :: Properties r -> CustomConfig+mkCustomConfig = CustomConfig++defaultConfigDescriptor :: ConfigDescriptor+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 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.+ --+ --+ -- 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)+ -- * Statically enabled (e.g. by configuration in the lsp-client)+ -- * Strictly speaking, this might also change dynamically+ --+ -- But there is no use to split it up into two different methods for now.+ 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+ -- e.g. 'pluginFileType' specifies which file extensions a plugin is allowed to handle+ -> PluginDescriptor c+ -- ^ Contains meta information such as PluginId and which file types this+ -- plugin is able to handle.+ -> Config+ -- ^ Generic config description, expected to contain 'PluginConfig' configuration+ -- for this plugin+ -> HandleRequestResult+ -- ^ Is this plugin enabled and allowed to respond to the given request+ -- with the given parameters?++ 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++-- | 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++-- | 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+ handlesRequest = pluginEnabledWithFeature plcCodeActionsOn++instance PluginMethod Request Method_CodeActionResolve where+ -- See Note [Resolve in PluginHandlers]+ handlesRequest = pluginEnabledResolve plcCodeActionsOn++instance PluginMethod Request Method_TextDocumentDefinition where+ handlesRequest vfs _ msgParams pluginDesc _ = pluginSupportsFileType vfs msgParams pluginDesc++instance PluginMethod Request Method_TextDocumentTypeDefinition where+ 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+ handlesRequest vfs _ msgParams pluginDesc _ = pluginSupportsFileType vfs msgParams pluginDesc++instance PluginMethod Request Method_TextDocumentReferences where+ handlesRequest vfs _ msgParams pluginDesc _ = pluginSupportsFileType vfs msgParams pluginDesc++instance PluginMethod Request Method_WorkspaceSymbol where+ -- Unconditionally enabled, but should it really be?+ 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+ handlesRequest = pluginEnabledWithFeature plcCodeLensOn++instance PluginMethod Request Method_CodeLensResolve where+ -- See Note [Resolve in PluginHandlers]+ handlesRequest = pluginEnabledResolve plcCodeLensOn++instance PluginMethod Request Method_TextDocumentRename where+ handlesRequest = pluginEnabledWithFeature plcRenameOn++instance PluginMethod Request Method_TextDocumentPrepareRename where+ handlesRequest = pluginEnabledWithFeature plcRenameOn++instance PluginMethod Request Method_TextDocumentHover where+ handlesRequest = pluginEnabledWithFeature plcHoverOn++instance PluginMethod Request Method_TextDocumentDocumentSymbol where+ handlesRequest = pluginEnabledWithFeature plcSymbolsOn++instance PluginMethod Request Method_TextDocumentSignatureHelp where+ handlesRequest = pluginEnabledWithFeature plcSignatureHelpOn++instance PluginMethod Request Method_CompletionItemResolve where+ -- See Note [Resolve in PluginHandlers]+ handlesRequest = pluginEnabledResolve plcCompletionOn++instance PluginMethod Request Method_TextDocumentCompletion where+ handlesRequest = pluginEnabledWithFeature plcCompletionOn++instance PluginMethod Request Method_TextDocumentFormatting where+ 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+ pid = pluginId pluginDesc++instance PluginMethod Request Method_TextDocumentRangeFormatting where+ 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+ 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+ handlesRequest = pluginEnabledWithFeature plcCallHierarchyOn++instance PluginMethod Request Method_TextDocumentSelectionRange where+ handlesRequest = pluginEnabledWithFeature plcSelectionRangeOn++instance PluginMethod Request Method_TextDocumentFoldingRange where+ handlesRequest = pluginEnabledWithFeature plcFoldingRangeOn++instance PluginMethod Request Method_CallHierarchyIncomingCalls where+ -- This method has no URI parameter, thus no call to 'pluginResponsible'+ 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'+ handlesRequest _ _ _ pluginDesc conf =+ pluginEnabledGlobally pluginDesc conf+ <> pluginFeatureEnabled plcCallHierarchyOn pluginDesc conf++instance PluginMethod Request Method_WorkspaceExecuteCommand where+ handlesRequest _ _ _ _ _ = HandlesRequest++instance PluginMethod Request (Method_CustomMethod m) where+ 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 $ concatMap (filter wasRequested) $ mapMaybe nullToMaybe $ toList resps+ where+ compat :: (Command |? CodeAction) -> (Command |? CodeAction)+ compat x@(InL _) = x+ compat x@(InR action)+ | Just _ <- textDocCaps >>= _codeAction >>= _codeActionLiteralSupport+ = x+ | otherwise = InL cmd+ where+ cmd = mkLspCommand "hls" "fallbackCodeAction" (action ^. L.title) (Just cmdParams)+ cmdParams = [toJSON (FallbackCodeActionParams (action ^. L.edit) (action ^. L.command))]++ wasRequested :: (Command |? CodeAction) -> Bool+ wasRequested (InL _) = True+ wasRequested (InR ca)+ | Nothing <- _only context = True+ | Just allowed <- _only context+ -- See https://github.com/microsoft/language-server-protocol/issues/970+ -- This is somewhat vague, but due to the hierarchical nature of action kinds, we+ -- 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 (`codeActionKindSubsumes` caKind) allowed+ | otherwise = False++instance PluginRequestMethod Method_CodeActionResolve where+ -- A resolve request should only have one response.+ -- See Note [Resolve in PluginHandlers].+ combineResponses _ _ _ _ (x :| _) = x++instance PluginRequestMethod Method_TextDocumentDefinition where+ 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 _ _ 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++instance PluginRequestMethod Method_WorkspaceSymbol where+ -- TODO: combine WorkspaceSymbol. Currently all WorkspaceSymbols are dumped+ -- as it is new of lsp-types 2.0.0.0+ combineResponses _ _ _ _ xs = InL $ mconcat $ takeLefts $ toList xs++instance PluginRequestMethod Method_TextDocumentCodeLens where++instance PluginRequestMethod Method_CodeLensResolve where+ -- A resolve request should only ever get one response.+ -- See note Note [Resolve in PluginHandlers]+ combineResponses _ _ _ _ (x :| _) = x++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])) =+ if null hs+ then InR Null+ else InL $ Hover (InL mcontent) r+ where+ r = listToMaybe $ mapMaybe (^. L.range) hs+ -- We are only taking MarkupContent here, because MarkedStrings have been+ -- deprecated for a while and don't occur in the hls codebase+ mcontent :: MarkupContent+ mcontent = mconcat $ takeLefts $ map (^. L.contents) hs++instance PluginRequestMethod Method_TextDocumentDocumentSymbol where+ combineResponses _ _ (ClientCapabilities _ tdc _ _ _ _) params xs = res+ where+ uri' = params ^. L.textDocument . L.uri+ supportsHierarchy = Just True == (tdc >>= _documentSymbol >>= _hierarchicalDocumentSymbolSupport)+ dsOrSi :: [Either [SymbolInformation] [DocumentSymbol]]+ dsOrSi = toEither <$> mapMaybe nullToMaybe' (toList xs)+ res :: [SymbolInformation] |? ([DocumentSymbol] |? Null)+ res+ | supportsHierarchy = InR $ InL $ concatMap (either (fmap siToDs) id) dsOrSi+ | otherwise = InL $ concatMap (either id ( concatMap dsToSi)) dsOrSi+ -- Is this actually a good conversion? It's what there was before, but some+ -- things such as tags are getting lost+ siToDs :: SymbolInformation -> DocumentSymbol+ siToDs (SymbolInformation name kind _tags cont dep (Location _uri range) )+ = DocumentSymbol name cont kind Nothing dep range range Nothing+ dsToSi = go Nothing+ go :: Maybe T.Text -> DocumentSymbol -> [SymbolInformation]+ go parent ds =+ let children' :: [SymbolInformation]+ children' = concatMap (go (Just name')) (fromMaybe mempty (ds ^. L.children))+ loc = Location uri' (ds ^. L.range)+ name' = ds ^. L.name+ 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]+ combineResponses _ _ _ _ (x :| _) = x++instance PluginRequestMethod Method_TextDocumentCompletion where+ combineResponses _ conf _ _ (toList -> xs) = snd $ consumeCompletionResponse limit $ combine xs+ where+ limit = maxCompletions conf+ combine :: [[CompletionItem] |? (CompletionList |? Null)] -> ([CompletionItem] |? (CompletionList |? Null))+ combine cs = go True mempty cs++ go :: Bool -> DList.DList CompletionItem -> [[CompletionItem] |? (CompletionList |? Null)] -> ([CompletionItem] |? (CompletionList |? Null))+ go !comp acc [] =+ InR (InL (CompletionList comp Nothing ( DList.toList acc)))+ go comp acc ((InL ls) : rest) =+ go comp (acc <> DList.fromList ls) rest+ go comp acc ( (InR (InL (CompletionList comp' _ ls))) : rest) =+ go (comp && comp') (acc <> DList.fromList ls) rest+ go comp acc ( (InR (InR Null)) : rest) =+ go comp acc rest+ -- boolean disambiguators+ isCompleteResponse, isIncompleteResponse :: Bool+ isIncompleteResponse = True+ isCompleteResponse = False+ consumeCompletionResponse :: Int -> ([CompletionItem] |? (CompletionList |? Null)) -> (Int, [CompletionItem] |? (CompletionList |? Null))+ consumeCompletionResponse limit it@(InR (InL (CompletionList _ _ xx))) =+ case splitAt limit xx of+ -- consumed all the items, return the result as is+ (_, []) -> (limit - length xx, it)+ -- need to crop the response, set the 'isIncomplete' flag+ (xx', _) -> (0, InR (InL (CompletionList isIncompleteResponse Nothing xx')))+ consumeCompletionResponse n (InL xx) =+ consumeCompletionResponse n (InR (InL (CompletionList isCompleteResponse Nothing xx)))+ consumeCompletionResponse n (InR (InR Null)) = (n, InR (InR Null))+instance PluginRequestMethod Method_TextDocumentFormatting where+ combineResponses _ _ _ _ (x :| _) = x++instance PluginRequestMethod Method_TextDocumentRangeFormatting where+ combineResponses _ _ _ _ (x :| _) = x++instance PluginRequestMethod Method_TextDocumentPrepareCallHierarchy where++instance PluginRequestMethod Method_TextDocumentSelectionRange where+ combineResponses _ _ _ _ (x :| _) = x++instance PluginRequestMethod Method_TextDocumentFoldingRange where+ combineResponses _ _ _ _ x = sconcat x++instance PluginRequestMethod Method_CallHierarchyIncomingCalls where++instance PluginRequestMethod Method_CallHierarchyOutgoingCalls where++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])++nullToMaybe' :: (a |? (b |? Null)) -> Maybe (a |? b)+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+-- ---------------------------------------------------------------------++-- | Plugin Notification methods. No specific methods at the moment, but+-- might contain more in the future.+class PluginMethod Notification m => PluginNotificationMethod (m :: Method ClientToServer Notification) where+++instance PluginNotificationMethod Method_TextDocumentDidOpen where++instance PluginNotificationMethod Method_TextDocumentDidChange where++instance PluginNotificationMethod Method_TextDocumentDidSave where++instance PluginNotificationMethod Method_TextDocumentDidClose where++instance PluginNotificationMethod Method_WorkspaceDidChangeWatchedFiles where++instance PluginNotificationMethod Method_WorkspaceDidChangeWorkspaceFolders where++instance PluginNotificationMethod Method_WorkspaceDidChangeConfiguration where++instance PluginNotificationMethod Method_Initialized where++-- ---------------------------------------------------------------------++-- | Methods which have a PluginMethod instance+data IdeMethod (m :: Method ClientToServer Request) = PluginRequestMethod m => IdeMethod (SMethod m)+instance GEq IdeMethod where+ geq (IdeMethod a) (IdeMethod b) = geq a b+instance GCompare IdeMethod where+ gcompare (IdeMethod a) (IdeMethod b) = gcompare a b++-- | Methods which have a PluginMethod instance+data IdeNotification (m :: Method ClientToServer Notification) = PluginNotificationMethod m => IdeNotification (SMethod m)+instance GEq IdeNotification where+ geq (IdeNotification a) (IdeNotification b) = geq a b+instance GCompare IdeNotification where+ gcompare (IdeNotification a) (IdeNotification b) = gcompare a b++-- | 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 -> HandlerM Config (NonEmpty (Either PluginError (MessageResult m))))++newtype PluginNotificationHandler a (m :: Method ClientToServer Notification)+ = PluginNotificationHandler (PluginId -> a -> VFS -> MessageParams m -> LspM Config ())++newtype PluginHandlers a = PluginHandlers (DMap IdeMethod (PluginHandler a))+newtype PluginNotificationHandlers a = PluginNotificationHandlers (DMap IdeNotification (PluginNotificationHandler a))+instance Semigroup (PluginHandlers a) where+ (PluginHandlers a) <> (PluginHandlers b) = PluginHandlers $ DMap.unionWithKey go a b+ where+ go _ (PluginHandler f) (PluginHandler g) = PluginHandler $ \pid ide params ->+ (<>) <$> f pid ide params <*> g pid ide params++instance Monoid (PluginHandlers a) where+ mempty = PluginHandlers mempty++instance Semigroup (PluginNotificationHandlers a) where+ (PluginNotificationHandlers a) <> (PluginNotificationHandlers b) = PluginNotificationHandlers $ DMap.unionWithKey go a b+ where+ go _ (PluginNotificationHandler f) (PluginNotificationHandler g) = PluginNotificationHandler $ \pid ide vfs params ->+ f pid ide vfs params >> g pid ide vfs params++instance Monoid (PluginNotificationHandlers a) where+ mempty = PluginNotificationHandlers mempty++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 ()++-- | Make a handler for plugins. For how resolve works with this see+-- Note [Resolve in PluginHandlers]+mkPluginHandler+ :: forall ideState m. PluginRequestMethod m+ => SClientMethod m+ -> PluginMethodHandler ideState m+ -> PluginHandlers ideState+mkPluginHandler m f = PluginHandlers $ DMap.singleton (IdeMethod m) (PluginHandler (f' m))+ where+ 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}} =+ pure . fmap (wrapCodeActions pid _uri) <$> runExceptT (f ide pid params)+ f' SMethod_TextDocumentCodeLens pid ide params@CodeLensParams{_textDocument=TextDocumentIdentifier {_uri}} =+ pure . fmap (wrapCodeLenses pid _uri) <$> runExceptT (f ide pid params)+ f' SMethod_TextDocumentCompletion pid ide params@CompletionParams{_textDocument=TextDocumentIdentifier {_uri}} =+ pure . fmap (wrapCompletions pid _uri) <$> runExceptT (f ide pid params)++ -- This is the default case for all other methods+ f' _ pid ide params = pure <$> runExceptT (f ide pid params)++ -- Todo: use fancy pancy lenses to make this a few lines+ wrapCodeActions pid uri (InL ls) =+ let wrapCodeActionItem pid uri (InR c) = InR $ wrapResolveData pid uri c+ wrapCodeActionItem _ _ command@(InL _) = command+ in InL $ wrapCodeActionItem pid uri <$> ls+ wrapCodeActions _ _ (InR r) = InR r++ wrapCodeLenses pid uri (InL ls) = InL $ wrapResolveData pid uri <$> ls+ wrapCodeLenses _ _ (InR r) = InR r++ wrapCompletions pid uri (InL ls) = InL $ wrapResolveData pid uri <$> ls+ wrapCompletions pid uri (InR (InL cl@(CompletionList{_items}))) =+ InR $ InL $ cl & L.items .~ (wrapResolveData pid uri <$> _items)+ wrapCompletions _ _ (InR (InR r)) = InR $ InR r++-- | Make a handler for plugins with no extra data+mkPluginNotificationHandler+ :: PluginNotificationMethod m+ => SClientMethod (m :: Method ClientToServer Notification)+ -> PluginNotificationMethodHandler ideState m+ -> PluginNotificationHandlers ideState+mkPluginNotificationHandler m f+ = PluginNotificationHandlers $ DMap.singleton (IdeNotification m) (PluginNotificationHandler f')+ where+ f' pid ide vfs = f ide vfs pid++defaultPluginPriority :: Natural+defaultPluginPriority = 1000++-- | Set up a plugin descriptor, initialized with default values.+-- This plugin descriptor is prepared for @haskell@ files, such as+--+-- * @.hs@+-- * @.lhs@+-- * @.hs-boot@+--+-- and handlers will be enabled for files with the appropriate file+-- extensions.+defaultPluginDescriptor :: PluginId -> T.Text -> PluginDescriptor ideState+defaultPluginDescriptor plId desc =+ PluginDescriptor+ plId+ desc+ defaultPluginPriority+ mempty+ mempty+ mempty+ defaultConfigDescriptor+ mempty+ mempty+ Nothing+ [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,+-- will only respond / run when @.cabal@ files are currently in scope.+--+-- Handles files with the following extensions:+-- * @.cabal@+defaultCabalPluginDescriptor :: PluginId -> T.Text -> PluginDescriptor ideState+defaultCabalPluginDescriptor plId desc =+ PluginDescriptor+ plId+ desc+ defaultPluginPriority+ mempty+ mempty+ mempty+ defaultConfigDescriptor+ mempty+ mempty+ Nothing+ [J.LanguageKind_Custom "cabal"]++newtype CommandId = CommandId T.Text+ deriving (Show, Read, Eq, Ord)+instance IsString CommandId where+ fromString = CommandId . T.pack++data PluginCommand ideState = forall a. (FromJSON a) =>+ PluginCommand { commandId :: CommandId+ , commandDesc :: T.Text+ , commandFunc :: CommandFunction ideState a+ }++-- ---------------------------------------------------------------------++type CommandFunction ideState a+ = ideState+ -> Maybe ProgressToken+ -> a+ -> ExceptT PluginError (HandlerM Config) (Value |? Null)++-- ---------------------------------------------------------------------++type ResolveFunction ideState a (m :: Method ClientToServer Request) =+ ideState+ -> PluginId+ -> MessageParams m+ -> Uri+ -> a+ -> 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]+mkResolveHandler+ :: forall ideState a m. (FromJSON a, PluginRequestMethod m, L.HasData_ (MessageParams m) (Maybe Value))+ => SClientMethod m+ -> ResolveFunction ideState a m+ -> PluginHandlers ideState+mkResolveHandler m f = mkPluginHandler m $ \ideState plId params -> do+ case fromJSON <$> (params ^. L.data_) of+ (Just (Success (PluginResolveData owner@(PluginId ownerName) uri value) )) -> do+ if owner == plId+ then+ case fromJSON value of+ Success decodedValue ->+ let newParams = params & L.data_ ?~ value+ in f ideState plId newParams uri decodedValue+ 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+ (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+ -- If we are getting params without a decodable data field, this means that+ -- there is an error, as we filter these our in `pluginEnabled`+ (Just (Error err)) -> throwError $ PluginInternalError (parseError (params ^. L.data_) err)+ -- If there are no params at all, this also means that there is an error,+ -- 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)++wrapResolveData :: L.HasData_ a (Maybe Value) => PluginId -> Uri -> a -> a+wrapResolveData pid uri hasData =+ hasData & L.data_ .~ (toJSON . PluginResolveData pid uri <$> data_)+ where data_ = hasData ^? L.data_ . _Just++-- |Allow plugins to "own" resolve data, allowing only them to be queried for+-- the resolve action. This design has added flexibility at the cost of nested+-- Value types+data PluginResolveData = PluginResolveData {+ resolvePlugin :: PluginId+, resolveURI :: Uri+, resolveValue :: Value+}+ deriving (Generic, Show)+ deriving anyclass (ToJSON, FromJSON)++newtype PluginId = PluginId T.Text+ deriving (Show, Read, Eq, Ord)+ deriving newtype (ToJSON, FromJSON, Hashable)++instance IsString PluginId where+ fromString = PluginId . T.pack+++-- ---------------------------------------------------------------------++-- | Format the given Text as a whole or only a @Range@ of it.+-- Range must be relative to the text to format.+-- To format the whole document, read the Text from the file and use 'FormatText'+-- as the FormattingType.+data FormattingType = FormatText+ | FormatRange Range+++type FormattingMethod m =+ ( L.HasOptions (MessageParams m) FormattingOptions+ , L.HasTextDocument (MessageParams m) TextDocumentIdentifier+ , MessageResult m ~ ([TextEdit] |? Null)+ )++type FormattingHandler a+ = a+ -> Maybe ProgressToken+ -> FormattingType+ -> T.Text+ -> NormalizedFilePath+ -> FormattingOptions+ -> ExceptT PluginError (HandlerM Config) ([TextEdit] |? Null)++-- ---------------------------------------------------------------------++data FallbackCodeActionParams =+ FallbackCodeActionParams+ { fallbackWorkspaceEdit :: Maybe WorkspaceEdit+ , fallbackCommand :: Maybe Command+ }+ deriving (Generic, ToJSON, FromJSON)++-- ---------------------------------------------------------------------++otSetUri :: SpanInFlight -> Uri -> IO ()+otSetUri sp (Uri t) = setTag sp "uri" (encodeUtf8 t)++class HasTracing a where+ traceWithSpan :: SpanInFlight -> a -> IO ()+ traceWithSpan _ _ = pure ()++instance {-# OVERLAPPABLE #-} (L.HasTextDocument a doc, L.HasUri doc Uri) => HasTracing a where+ traceWithSpan sp a = otSetUri sp (a ^. L.textDocument . L.uri)++instance HasTracing Value+instance HasTracing ExecuteCommandParams+instance HasTracing DidChangeWatchedFilesParams where+ traceWithSpan sp DidChangeWatchedFilesParams{_changes} =+ setTag sp "changes" (encodeUtf8 $ fromString $ show _changes)+instance HasTracing DidChangeWorkspaceFoldersParams+instance HasTracing DidChangeConfigurationParams+instance HasTracing InitializeParams+instance HasTracing InitializedParams+instance HasTracing WorkspaceSymbolParams where+ traceWithSpan sp (WorkspaceSymbolParams _ _ query) = setTag sp "query" (encodeUtf8 query)+instance HasTracing CallHierarchyIncomingCallsParams+instance HasTracing CallHierarchyOutgoingCallsParams++-- Instances for resolve types+instance HasTracing CodeAction+instance HasTracing CodeLens+instance HasTracing CompletionItem+instance HasTracing DocumentLink+instance HasTracing InlayHint+instance HasTracing WorkspaceSymbol+-- ---------------------------------------------------------------------+--Experimental resolve refactoring+{-# NOINLINE pROCESS_ID #-}+pROCESS_ID :: T.Text+pROCESS_ID = unsafePerformIO getPid++mkLspCommand :: PluginId -> CommandId -> T.Text -> Maybe [Value] -> Command+mkLspCommand plid cn title args = Command title cmdId args+ where+ cmdId = mkLspCmdId pROCESS_ID plid cn++mkLspCmdId :: T.Text -> PluginId -> CommandId -> T.Text+mkLspCmdId pid (PluginId plid) (CommandId cid)+ = pid <> ":" <> plid <> ":" <> cid++-- | Get the operating system process id for the running server+-- instance. This should be the same for the lifetime of the instance,+-- and different from that of any other currently running instance.+getPid :: IO T.Text+getPid = T.pack . show <$> getProcessID++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 ()++#ifdef mingw32_HOST_OS+getProcessID = fromIntegral <$> P.getCurrentProcessId+installSigUsr1Handler _ = return ()++#else+getProcessID = fromIntegral <$> P.getProcessID++installSigUsr1Handler h = void $ installHandler sigUSR1 (Catch h) Nothing+#endif++{- 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+ the same requirements have their own codepaths for execution, for resolve+ methods we are relying on the standard PluginHandlers codepath.+ That isn't a problem, but it does mean we need to do some things extra for+ these methods.+ - First of all, whenever a handler that can be resolved sets the data_ field+ in their response, we need to intercept it, and wrap it in a data type+ PluginResolveData that allows us to route the future resolve request to the+ specific plugin which is responsible for it. (We also throw in the URI for+ convenience, because everyone needs that). We do that in mkPluginHandler.+ - When we get any resolve requests we check their data field for our+ PluginResolveData that will allow us to route the request to the right+ plugin. If we can't find out which plugin to route the request to, then we+ just don't route it at all. This is done in pluginEnabled, and+ pluginResolverResponsible.+ - Finally we have mkResolveHandler, which takes the resolve request and+ unwraps the plugins data from our PluginResolveData, parses it and passes it+ it on to the registered handler.+ It should be noted that there are some restrictions with this approach: First,+ if a plugin does not set the data_ field, than the request will not be able+ to be resolved. This is because we only wrap data_ fields that have been set+ with our PluginResolvableData tag. Second, if a plugin were to register two+ resolve handlers for the same method, than our assumptions that we never have+ two responses break, and behavior is undefined.+ -}
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.Set as Set-import qualified Data.Text as T-import qualified Ide.Plugin.RangeMap as RangeMap-import Ide.PluginUtils (positionInRange, unescape)-import Language.LSP.Types (Position (..), Range (Range), UInt,- isSubrangeOf)+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 (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 ]