diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,56 @@ +-- A benchmark comparing the performance characteristics of list-based +-- vs RangeMap-based "in-range filtering" approaches +module Main (main) where + +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.Protocol.Types (Position (..), Range (..), UInt, + isSubrangeOf) +import qualified System.Random.Stateful as Random + + +genRangeList :: Int -> RVar [Range] +genRangeList n = replicateM n genRange + +genRange :: RVar Range +genRange = do + x1 <- genPosition + delta <- genRangeLength + let x2 = x1 { _character = _character x1 + delta } + pure $ Range x1 x2 + where + genRangeLength :: RVar UInt + genRangeLength = fromInteger <$> Fu.uniform 5 50 + +genPosition :: RVar Position +genPosition = Position + <$> (fromInteger <$> Fu.uniform 0 10000) + <*> (fromInteger <$> Fu.uniform 0 150) + +filterRangeList :: Range -> [Range] -> [Range] +filterRangeList r = filter (isSubrangeOf r) + +main :: IO () +main = do + rangeLists@[rangeList100, rangeList1000, rangeList10000] + <- traverse (Fu.sampleFrom Random.globalStdGen . genRangeList) [100, 1000, 10000] + [rangeMap100, rangeMap1000, rangeMap10000] <- evaluate $ force $ map (RangeMap.fromList id) rangeLists + targetRange <- Fu.sampleFrom Random.globalStdGen genRange + Criterion.Main.defaultMain + [ Criterion.bgroup "List" + [ Criterion.bench "Size 100" $ Criterion.nf (filterRangeList targetRange) rangeList100 + , Criterion.bench "Size 1000" $ Criterion.nf (filterRangeList targetRange) rangeList1000 + , Criterion.bench "Size 10000" $ Criterion.nf (filterRangeList targetRange) rangeList10000 + ] + , Criterion.bgroup "RangeMap" + [ Criterion.bench "Size 100" $ Criterion.nf (RangeMap.filterByRange targetRange) rangeMap100 + , Criterion.bench "Size 1000" $ Criterion.nf (RangeMap.filterByRange targetRange) rangeMap1000 + , Criterion.bench "Size 10000" $ Criterion.nf (RangeMap.filterByRange targetRange) rangeMap10000 + ] + ] diff --git a/hls-plugin-api.cabal b/hls-plugin-api.cabal --- a/hls-plugin-api.cabal +++ b/hls-plugin-api.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-plugin-api -version: 1.4.0.0 +version: 2.14.0.0 synopsis: Haskell Language Server API for plugin communication description: Please see the README on GitHub at @@ -20,15 +20,34 @@ default: False manual: True +-- This flag can be used to avoid the dependency on hw-fingertree. +-- We can set this temporarily if we have problems building hw-fingertree +-- for a new version of GHC. +flag use-fingertree + description: Use fingertree implementation of RangeMap + default: True + manual: False + source-repository head 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 @@ -36,25 +55,32 @@ build-depends: , aeson , base >=4.12 && <5 + , co-log-core , containers , data-default , dependent-map - , dependent-sum - , Diff ^>=0.4.0 + , dependent-sum >=0.7 + , Diff ^>=0.5 || ^>=1.0.0 , dlist , extra + , filepath , ghc , hashable - , hls-graph ^>= 1.7 + , hls-graph == 2.14.0.0 , lens , lens-aeson - , lsp >=1.4.0.0 && < 1.6 - , opentelemetry + , lsp ^>=2.8 + , megaparsec >=9.0 + , mtl + , opentelemetry >=0.4 , optparse-applicative - , process + , prettyprinter , regex-tdfa >=1.3.1.0 + , stm , text + , time , transformers + , unliftio , unordered-containers if os(windows) @@ -63,30 +89,61 @@ else build-depends: unix - ghc-options: - -Wall -Wredundant-constraints -Wno-name-shadowing - -Wno-unticked-promoted-constructors - if flag(pedantic) ghc-options: -Werror - default-language: Haskell2010 + if flag(use-fingertree) + cpp-options: -DUSE_FINGERTREE + build-depends: hw-fingertree + + 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-quickcheck , tasty-rerun + , text + +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: GHC2021 + hs-source-dirs: bench + main-is: Main.hs + ghc-options: -threaded + build-depends: + , base + , criterion + , deepseq + , hls-plugin-api , lsp-types + , random + , random-fu diff --git a/src/Ide/Logger.hs b/src/Ide/Logger.hs new file mode 100644 --- /dev/null +++ b/src/Ide/Logger.hs @@ -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 -> "" + 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 diff --git a/src/Ide/Plugin/Config.hs b/src/Ide/Plugin/Config.hs --- a/src/Ide/Plugin/Config.hs +++ b/src/Ide/Plugin/Config.hs @@ -1,10 +1,7 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} module Ide.Plugin.Config ( getConfigFromNotification , Config(..) @@ -13,149 +10,74 @@ , CheckParents(..) ) where -import Control.Applicative -import Data.Aeson hiding (Error) -import qualified Data.Aeson as A -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 as Map -import qualified Data.Text as T -import GHC.Generics (Generic) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe) +import qualified Data.Text as T +import GHC.Exts (toList) +import Ide.Types -- --------------------------------------------------------------------- -- | Given a DidChangeConfigurationNotification message, this function returns the parsed -- Config object if possible. -getConfigFromNotification :: Config -> A.Value -> Either T.Text Config -getConfigFromNotification defaultValue p = - case A.parse (parseConfig defaultValue) p of +getConfigFromNotification :: IdePlugins s -> Config -> A.Value -> Either T.Text Config +getConfigFromNotification plugins defaultValue p = + case A.parse (parseConfig plugins defaultValue) p of A.Success c -> Right c A.Error err -> Left $ T.pack err -- --------------------------------------------------------------------- -data CheckParents - -- Note that ordering of constructors is meaningful and must be monotonically - -- increasing in the scenarios where parents are checked - = NeverCheck - | CheckOnSave - | AlwaysCheck - deriving stock (Eq, Ord, Show, Generic) - deriving anyclass (FromJSON, ToJSON) --- | We (initially anyway) mirror the hie configuration, so that existing --- clients can simply switch executable and not have any nasty surprises. There --- will be surprises relating to config options being ignored, initially though. -data Config = +parseConfig :: IdePlugins s -> Config -> Value -> A.Parser Config +parseConfig idePlugins defValue = A.withObject "settings" $ \o -> Config - { checkParents :: CheckParents - , checkProject :: !Bool - , formattingProvider :: !T.Text - , maxCompletions :: !Int - , plugins :: !(Map.Map T.Text PluginConfig) - } deriving (Show,Eq) - -instance Default Config where - def = Config - { checkParents = CheckOnSave - , checkProject = True - -- , formattingProvider = "brittany" - , formattingProvider = "ormolu" - -- , formattingProvider = "floskell" - -- , formattingProvider = "stylish-haskell" - , maxCompletions = 40 - , plugins = Map.empty - } - --- TODO: Add API for plugins to expose their own LSP config options -parseConfig :: Config -> Value -> A.Parser Config -parseConfig defValue = A.withObject "Config" $ \v -> do - -- Officially, we use "haskell" as the section name but for - -- backwards compatibility we also accept "languageServerHaskell" - c <- v .: "haskell" <|> v .:? "languageServerHaskell" - case c of - Nothing -> return defValue - Just s -> flip (A.withObject "Config.settings") s $ \o -> Config - <$> (o .:? "checkParents" <|> v .:? "checkParents") .!= checkParents defValue - <*> (o .:? "checkProject" <|> v .:? "checkProject") .!= checkProject defValue - <*> o .:? "formattingProvider" .!= formattingProvider defValue - <*> o .:? "maxCompletions" .!= maxCompletions defValue - <*> o .:? "plugin" .!= plugins defValue + <$> 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 -instance A.ToJSON Config where - toJSON Config{..} = - object [ "haskell" .= r ] - where - r = object [ "checkParents" .= checkParents - , "checkProject" .= checkProject - , "formattingProvider" .= formattingProvider - , "maxCompletions" .= maxCompletions - , "plugin" .= plugins - ] +-- | Parse the 'PluginConfig'. +-- Since we need to fall back to default values if we do not find one in the input, +-- we need the map of plugin-provided defaults, as in 'parseConfig'. +parsePlugins :: IdePlugins s -> Value -> A.Parser (Map.Map PluginId PluginConfig) +parsePlugins (IdePlugins plugins) = A.withObject "Config.plugins" $ \o -> do + let -- parseOne :: Key -> Value -> A.Parser (T.Text, PluginConfig) + parseOne (fmap PluginId . preview _String . toJSON -> Just pId) pConfig = do + let defPluginConfig = fromMaybe def $ lookup pId defValue + pConfig' <- parsePluginConfig defPluginConfig pConfig + return (pId, pConfig') + parseOne _ _ = fail "Expected plugin id to be a string" + defValue = map (\p -> (pluginId p, configInitialGenericConfig (pluginConfigDescriptor p))) plugins + plugins <- mapM (uncurry parseOne) (toList o) + return $ Map.fromList plugins -- --------------------------------------------------------------------- --- | A PluginConfig is a generic configuration for a given HLS plugin. It --- provides a "big switch" to turn it on or off as a whole, as well as small --- switches per feature, and a slot for custom config. --- This provides a regular naming scheme for all plugin config. -data PluginConfig = - PluginConfig - { plcGlobalOn :: !Bool - , plcCallHierarchyOn :: !Bool - , plcCodeActionsOn :: !Bool - , plcCodeLensOn :: !Bool - , plcDiagnosticsOn :: !Bool - , plcHoverOn :: !Bool - , plcSymbolsOn :: !Bool - , plcCompletionOn :: !Bool - , plcRenameOn :: !Bool - , plcSelectionRangeOn :: !Bool - , plcConfig :: !A.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 - , plcConfig = mempty - } - -instance A.ToJSON PluginConfig where - toJSON (PluginConfig g ch ca cl d h s c rn sr 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 - , "config" .= cfg - ] - -instance A.FromJSON PluginConfig where - parseJSON = A.withObject "PluginConfig" $ \o -> PluginConfig +parsePluginConfig :: PluginConfig -> Value -> A.Parser 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 .:? "semanticTokensOn" .!= plcSemanticTokensOn def <*> o .:? "config" .!= plcConfig def -- --------------------------------------------------------------------- diff --git a/src/Ide/Plugin/ConfigUtils.hs b/src/Ide/Plugin/ConfigUtils.hs --- a/src/Ide/Plugin/ConfigUtils.hs +++ b/src/Ide/Plugin/ConfigUtils.hs @@ -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 Data.Default (def) -import qualified Data.Dependent.Map as DMap -import qualified Data.Dependent.Sum as DSum -import Data.List (nub) -import Data.String (IsString (fromString)) -import qualified Data.Text as T +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 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 <$> map snd 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] @@ -62,12 +74,14 @@ -- } -- genericDefaultConfig = - let x = ["diagnosticsOn" A..= True | configHasDiagnostics] <> nub (mconcat (handlersToGenericDefaultConfig <$> 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 - [_] -> ["globalOn" A..= True] - _ -> x + let x = ["diagnosticsOn" A..= True | configHasDiagnostics] + <> 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 omit globalOn + [_] -> ["globalOn" A..= plcGlobalOn configInitialGenericConfig] + _ -> x -- Example: -- -- { @@ -82,21 +96,25 @@ (PluginId pId) = pluginId -- This function captures ide methods registered by the plugin, and then converts it to kv pairs - handlersToGenericDefaultConfig :: DSum.DSum IdeMethod f -> [A.Pair] - handlersToGenericDefaultConfig (IdeMethod m DSum.:=> _) = case m of - STextDocumentCodeAction -> ["codeActionsOn" A..= True] - STextDocumentCodeLens -> ["codeLensOn" A..= True] - STextDocumentRename -> ["renameOn" A..= True] - STextDocumentHover -> ["hoverOn" A..= True] - STextDocumentDocumentSymbol -> ["symbolsOn" A..= True] - STextDocumentCompletion -> ["completionOn" A..= True] - STextDocumentPrepareCallHierarchy -> ["callHierarchyOn" A..= True] + handlersToGenericDefaultConfig :: PluginConfig -> DSum.DSum IdeMethod f -> [A.Pair] + handlersToGenericDefaultConfig PluginConfig{..} (IdeMethod m DSum.:=> _) = case m of + SMethod_TextDocumentCodeAction -> ["codeActionsOn" A..= plcCodeActionsOn] + SMethod_TextDocumentCodeLens -> ["codeLensOn" A..= plcCodeLensOn] + SMethod_TextDocumentInlayHint -> ["inlayHintsOn" A..= plcInlayHintsOn] + SMethod_TextDocumentRename -> ["renameOn" A..= plcRenameOn] + SMethod_TextDocumentHover -> ["hoverOn" A..= plcHoverOn] + SMethod_TextDocumentDocumentSymbol -> ["symbolsOn" A..= plcSymbolsOn] + SMethod_TextDocumentSignatureHelp -> ["signatureHelpOn" A..= plcSignatureHelpOn] + SMethod_TextDocumentCompletion -> ["completionOn" A..= plcCompletionOn] + SMethod_TextDocumentPrepareCallHierarchy -> ["callHierarchyOn" A..= plcCallHierarchyOn] + SMethod_TextDocumentSemanticTokensFull -> ["semanticTokensOn" A..= plcSemanticTokensOn] + SMethod_TextDocumentSemanticTokensFullDelta -> ["semanticTokensOn" A..= plcSemanticTokensOn] _ -> [] -- | Generates json schema used in haskell vscode extension -- Similar to 'pluginsToDefaultConfig' but simpler, since schema has a flatten structure pluginsToVSCodeExtensionSchema :: IdePlugins a -> A.Value -pluginsToVSCodeExtensionSchema IdePlugins {..} = A.object $ mconcat $ singlePlugin <$> map snd ipMap +pluginsToVSCodeExtensionSchema IdePlugins {..} = A.object $ mconcat $ singlePlugin <$> ipMap where singlePlugin PluginDescriptor {pluginConfigDescriptor = ConfigDescriptor {..}, ..} = genericSchema <> dedicatedSchema where @@ -105,29 +123,122 @@ (PluginId pId) = pluginId genericSchema = let x = - [toKey' "diagnosticsOn" A..= schemaEntry "diagnostics" | configHasDiagnostics] - <> nub (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 = "" diff --git a/src/Ide/Plugin/Error.hs b/src/Ide/Plugin/Error.hs new file mode 100644 --- /dev/null +++ b/src/Ide/Plugin/Error.hs @@ -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 diff --git a/src/Ide/Plugin/HandleRequestTypes.hs b/src/Ide/Plugin/HandleRequestTypes.hs new file mode 100644 --- /dev/null +++ b/src/Ide/Plugin/HandleRequestTypes.hs @@ -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 diff --git a/src/Ide/Plugin/Properties.hs b/src/Ide/Plugin/Properties.hs --- a/src/Ide/Plugin/Properties.hs +++ b/src/Ide/Plugin/Properties.hs @@ -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] +} + diff --git a/src/Ide/Plugin/RangeMap.hs b/src/Ide/Plugin/RangeMap.hs new file mode 100644 --- /dev/null +++ b/src/Ide/Plugin/RangeMap.hs @@ -0,0 +1,93 @@ +{-# 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 +-- not, the map will be rebuilt upon each invocation, yielding slower +-- results compared to the list-based approach! +-- +-- Note that 'RangeMap' falls back to the list-based approach if +-- `use-fingertree` flag of `hls-plugin-api` is set to false. +module Ide.Plugin.RangeMap + ( RangeMap(..), + fromList, + fromList', + filterByRange, + elementsInRange, + ) where + +import Development.IDE.Graph.Classes (NFData) + +#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 + { unRangeMap :: IM.IntervalMap Position a + -- ^ 'IM.Interval' of 'Position' corresponds to a 'Range' + } + deriving newtype (NFData, Semigroup, Monoid) + deriving stock (Functor, Foldable, Traversable) +#else +newtype RangeMap a = RangeMap + { unRangeMap :: [(Range, a)] } + deriving newtype (NFData, Semigroup, Monoid) + deriving stock (Functor, Foldable, Traversable) +#endif + +-- | Construct a 'RangeMap' from a 'Range' accessor and a list of values. +fromList :: (a -> Range) -> [a] -> RangeMap a +fromList extractRange = fromList' . map (\x -> (extractRange x, x)) + +fromList' :: [(Range, a)] -> RangeMap a +#ifdef USE_FINGERTREE +fromList' = RangeMap . toIntervalMap . map (first rangeToInterval) + where + toIntervalMap :: Ord v => [(IM.Interval v, a)] -> IM.IntervalMap v a + toIntervalMap = foldl' (\m (i, v) -> IM.insert i v m) IM.empty +#else +fromList' = RangeMap +#endif + +-- | Filter a 'RangeMap' by a given 'Range'. +filterByRange :: Range -> RangeMap a -> [a] +#ifdef USE_FINGERTREE +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 +-- NOTE(ozkutuk): In itself, this conversion is wrong. As Michael put it: +-- "LSP Ranges have exclusive upper bounds, whereas the intervals here are +-- supposed to be closed (i.e. inclusive at both ends)" +-- However, in our use-case this turns out not to be an issue (supported +-- by the accompanying property test). I think the reason for this is, +-- even if rangeToInterval isn't a correct 1:1 conversion by itself, it +-- is used for both the construction of the RangeMap and during the actual +-- filtering (filterByRange), so it still behaves identical to the list +-- approach. +-- This definition isn't exported from the module, therefore we need not +-- worry about other uses where it potentially makes a difference. +rangeToInterval :: Range -> IM.Interval Position +rangeToInterval (Range s e) = IM.Interval s e +#endif diff --git a/src/Ide/Plugin/Resolve.hs b/src/Ide/Plugin/Resolve.hs new file mode 100644 --- /dev/null +++ b/src/Ide/Plugin/Resolve.hs @@ -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! + -} diff --git a/src/Ide/PluginUtils.hs b/src/Ide/PluginUtils.hs --- a/src/Ide/PluginUtils.hs +++ b/src/Ide/PluginUtils.hs @@ -1,22 +1,25 @@ -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} + module Ide.PluginUtils - ( WithDeletions(..), - getProcessID, + ( -- * LSP Range manipulation functions normalize, + extendNextLine, + extendLineStart, + extendToFullLines, + WithDeletions(..), + getProcessID, makeDiffTextEdit, makeDiffTextEditAdditive, diffText, diffText', pluginDescToIdePlugins, idePluginsToPluginDesc, - responseError, getClientConfig, getPluginConfig, configForPlugin, - pluginEnabled, - extractRange, + handlesRequest, + extractTextInRange, fullRange, mkLspCommand, mkLspCmdId, @@ -25,79 +28,111 @@ allLspCmdIds', installSigUsr1Handler, subRange, + rangesOverlap, positionInRange, usePropertyLsp, - getNormalizedFilePath, - response, - handleMaybe, - handleMaybeM, - ) + -- * Escape + unescape, + -- * toAbsolute + toAbsolute + ) where - -import Control.Lens ((^.)) -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.Containers.ListUtils (nubOrdOn) -import qualified Data.HashMap.Strict as H -import Data.String (IsString (fromString)) -import qualified Data.Text as T +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 Language.LSP.Types.Lens (uri) +import System.FilePath (()) +import qualified Text.Megaparsec as P +import qualified Text.Megaparsec.Char as P +import qualified Text.Megaparsec.Char.Lexer as P -- --------------------------------------------------------------------- -- | Extend to the line below and above to replace newline character. +-- +-- >>> normalize (Range (Position 5 5) (Position 5 10)) +-- Range (Position 5 0) (Position 6 0) normalize :: Range -> Range -normalize (Range (Position sl _) (Position el _)) = - Range (Position sl 0) (Position (el + 1) 0) +normalize = extendLineStart . extendNextLine +-- | Extend 'Range' to the start of the next line. +-- +-- >>> extendNextLine (Range (Position 5 5) (Position 5 10)) +-- Range (Position 5 5) (Position 6 0) +extendNextLine :: Range -> Range +extendNextLine (Range s (Position el _)) = + Range s (Position (el + 1) 0) + +-- | Extend 'Range' to the start of the current line. +-- +-- >>> extendLineStart (Range (Position 5 5) (Position 5 10)) +-- Range (Position 5 0) (Position 5 10) +extendLineStart :: Range -> Range +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 @@ -109,69 +144,69 @@ 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 -- --------------------------------------------------------------------- pluginDescToIdePlugins :: [PluginDescriptor ideState] -> IdePlugins ideState -pluginDescToIdePlugins plugins = - IdePlugins $ map (\p -> (pluginId p, p)) $ nubOrdOn pluginId plugins +pluginDescToIdePlugins = IdePlugins idePluginsToPluginDesc :: IdePlugins ideState -> [PluginDescriptor ideState] -idePluginsToPluginDesc (IdePlugins pp) = map snd pp +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 runitime change +-- 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 -- --------------------------------------------------------------------- @@ -179,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 => PluginId -> 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 -- --------------------------------------------------------------------- @@ -190,7 +225,7 @@ usePropertyLsp :: (HasProperty s k t r, MonadLsp Config m) => KeyNameProxy s -> - PluginId -> + PluginDescriptor c -> Properties r -> m (ToHsType t) usePropertyLsp kn pId p = do @@ -199,45 +234,70 @@ -- --------------------------------------------------------------------- -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 smallRange range = - positionInRange (_start smallRange) range - && positionInRange (_end smallRange) range +subRange = isSubrangeOf -positionInRange :: Position -> Range -> Bool -positionInRange p (Range sp ep) = sp <= p && p <= ep +-- | 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) = mkPlugin (allLspCmdIds pid) (Just . pluginCommands) - where - justs (p, Just x) = [(p, x)] - justs (_, Nothing) = [] - - - mkPlugin maker selector - = maker $ concatMap (\(pid, p) -> justs (pid, selector p)) ls - +allLspCmdIds' pid (IdePlugins ls) = + allLspCmdIds pid $ map (pluginId &&& pluginCommands) ls allLspCmdIds :: T.Text -> [(PluginId, [PluginCommand ideState])] -> [T.Text] allLspCmdIds pid commands = concatMap go commands @@ -246,22 +306,41 @@ -- --------------------------------------------------------------------- -getNormalizedFilePath :: Monad m => PluginId -> TextDocumentIdentifier -> ExceptT String m NormalizedFilePath -getNormalizedFilePath (PluginId plId) docId = handleMaybe errMsg - $ uriToNormalizedFilePath - $ toNormalizedUri uri' - where - errMsg = T.unpack $ "Error(" <> plId <> "): converting " <> getUri uri' <> " to NormalizedFilePath" - uri' = docId ^. uri --- --------------------------------------------------------------------- -handleMaybe :: Monad m => e -> Maybe b -> ExceptT e m b -handleMaybe msg = maybe (throwE msg) return +type TextParser = P.Parsec Void T.Text -handleMaybeM :: Monad m => e -> m (Maybe b) -> ExceptT e m b -handleMaybeM msg act = maybeM (throwE msg) return $ lift act +-- | Unescape printable escape sequences within double quotes. +-- This is useful if you have to call 'show' indirectly, and it escapes some characters which you would prefer to +-- display as is. +unescape :: T.Text -> T.Text +unescape input = + case P.runParser escapedTextParser "inline" input of + Left _ -> input + Right strs -> T.pack strs -response :: Monad m => ExceptT String m a -> m (Either ResponseError a) -response = - fmap (first (\msg -> ResponseError InternalError (fromString msg) Nothing)) - . runExceptT +-- | Parser for a string that contains double quotes. Returns unescaped string. +escapedTextParser :: TextParser String +escapedTextParser = concat <$> P.many (outsideStringLiteral P.<|> stringLiteral) + where + outsideStringLiteral :: TextParser String + outsideStringLiteral = P.someTill (P.anySingleBut '"') (P.lookAhead (void (P.char '"') P.<|> P.eof)) + + 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 + + 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 = () diff --git a/src/Ide/Types.hs b/src/Ide/Types.hs --- a/src/Ide/Types.hs +++ b/src/Ide/Types.hs @@ -1,533 +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 NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} - -module Ide.Types - where - -#ifdef mingw32_HOST_OS -import qualified System.Win32.Process as P (getCurrentProcessId) -#else -import Control.Monad (void) -import qualified System.Posix.Process as P (getProcessID) -import System.Posix.Signals -#endif -import Control.Lens ((^.)) -import Data.Aeson hiding (defaultOptions) -import qualified Data.DList as DList -import qualified Data.Default -import Data.Dependent.Map (DMap) -import qualified Data.Dependent.Map as DMap -import Data.GADT.Compare -import Data.List.NonEmpty (NonEmpty (..), toList) -import qualified Data.Map as Map -import Data.Maybe -import Data.Semigroup -import Data.String -import qualified Data.Text as T -import Data.Text.Encoding (encodeUtf8) -import Development.IDE.Graph -import GHC (DynFlags) -import GHC.Generics -import Ide.Plugin.Config -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 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 OpenTelemetry.Eventlog -import Options.Applicative (ParserInfo) -import System.IO.Unsafe -import Text.Regex.TDFA.Text () - --- --------------------------------------------------------------------- - -newtype IdePlugins ideState = IdePlugins - { ipMap :: [(PluginId, PluginDescriptor ideState)]} - deriving newtype (Monoid, Semigroup) - --- | 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 _ = "" - --- --------------------------------------------------------------------- - -data PluginDescriptor ideState = - PluginDescriptor { pluginId :: !PluginId - , pluginRules :: !(Rules ()) - , pluginCommands :: ![PluginCommand ideState] - , pluginHandlers :: PluginHandlers ideState - , pluginConfigDescriptor :: ConfigDescriptor - , pluginNotificationHandlers :: PluginNotificationHandlers ideState - , pluginModifyDynflags :: DynFlagsModifications - , pluginCli :: Maybe (ParserInfo (IdeCommand ideState)) - } - --- | 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 { - -- | Whether or not to generate generic configs. - configEnableGenericConfig :: Bool, - -- | 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 True 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 m where - - -- | Parse the configuration to check if this plugin is enabled - pluginEnabled :: SMethod m -> PluginId -> Config -> Bool - - -- | How to combine responses from different plugins - combineResponses - :: SMethod m - -> Config -- ^ IDE Configuration - -> ClientCapabilities - -> MessageParams m - -> NonEmpty (ResponseResult m) -> ResponseResult m - - default combineResponses :: Semigroup (ResponseResult m) - => SMethod m -> Config -> ClientCapabilities -> MessageParams m -> NonEmpty (ResponseResult m) -> ResponseResult m - combineResponses _method _config _caps _params = sconcat - -instance PluginMethod TextDocumentCodeAction where - pluginEnabled _ = pluginEnabledConfig plcCodeActionsOn - combineResponses _method _config (ClientCapabilities _ textDocCaps _ _ _) (CodeActionParams _ _ _ _ context) resps = - fmap compat $ List $ filter wasRequested $ (\(List x) -> x) $ sconcat resps - where - - compat :: (Command |? CodeAction) -> (Command |? CodeAction) - compat x@(InL _) = x - compat x@(InR action) - | Just _ <- textDocCaps >>= _codeAction >>= _codeActionLiteralSupport - = x - | otherwise = InL cmd - where - cmd = mkLspCommand "hls" "fallbackCodeAction" (action ^. title) (Just cmdParams) - cmdParams = [toJSON (FallbackCodeActionParams (action ^. edit) (action ^. command))] - - wasRequested :: (Command |? CodeAction) -> Bool - wasRequested (InL _) = True - wasRequested (InR ca) - | Nothing <- _only context = True - | Just (List allowed) <- _only context - -- 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 TextDocumentCodeLens where - pluginEnabled _ = pluginEnabledConfig plcCodeLensOn -instance PluginMethod TextDocumentRename where - pluginEnabled _ = pluginEnabledConfig plcRenameOn -instance PluginMethod TextDocumentHover where - pluginEnabled _ = pluginEnabledConfig plcHoverOn - combineResponses _ _ _ _ (catMaybes . toList -> hs) = h - where - r = listToMaybe $ mapMaybe (^. range) hs - h = case foldMap (^. contents) hs of - HoverContentsMS (List []) -> Nothing - hh -> Just $ Hover hh r - -instance PluginMethod TextDocumentDocumentSymbol where - pluginEnabled _ = pluginEnabledConfig plcSymbolsOn - combineResponses _ _ (ClientCapabilities _ tdc _ _ _) params xs = res - where - uri' = params ^. textDocument . uri - supportsHierarchy = Just True == (tdc >>= _documentSymbol >>= _hierarchicalDocumentSymbolSupport) - dsOrSi = fmap toEither xs - res - | supportsHierarchy = InL $ sconcat $ fmap (either id (fmap siToDs)) dsOrSi - | otherwise = InR $ sconcat $ fmap (either (List . concatMap dsToSi) id) dsOrSi - siToDs (SymbolInformation name kind _tags dep (Location _uri range) cont) - = DocumentSymbol name cont kind Nothing dep range range Nothing - dsToSi = go Nothing - go :: Maybe T.Text -> DocumentSymbol -> [SymbolInformation] - go parent ds = - let children' :: [SymbolInformation] - children' = concatMap (go (Just name')) (fromMaybe mempty (ds ^. children)) - loc = Location uri' (ds ^. range) - name' = ds ^. name - si = SymbolInformation name' (ds ^. kind) Nothing (ds ^. deprecated) loc parent - in [si] <> children' - -instance PluginMethod TextDocumentCompletion where - pluginEnabled _ = pluginEnabledConfig plcCompletionOn - combineResponses _ conf _ _ (toList -> xs) = snd $ consumeCompletionResponse limit $ combine xs - where - limit = maxCompletions conf - combine :: [List CompletionItem |? CompletionList] -> (List CompletionItem |? CompletionList) - combine cs = go True mempty cs - - go !comp acc [] = - InR (CompletionList comp (List $ DList.toList acc)) - go comp acc (InL (List ls) : rest) = - go comp (acc <> DList.fromList ls) rest - go comp acc (InR (CompletionList comp' (List ls)) : rest) = - go (comp && comp') (acc <> DList.fromList ls) rest - - -- boolean disambiguators - isCompleteResponse, isIncompleteResponse :: Bool - isIncompleteResponse = True - isCompleteResponse = False - - consumeCompletionResponse limit it@(InR (CompletionList _ (List xx))) = - case splitAt limit xx of - -- consumed all the items, return the result as is - (_, []) -> (limit - length xx, it) - -- need to crop the response, set the 'isIncomplete' flag - (xx', _) -> (0, InR (CompletionList isIncompleteResponse (List xx'))) - consumeCompletionResponse n (InL (List xx)) = - consumeCompletionResponse n (InR (CompletionList isCompleteResponse (List xx))) - -instance PluginMethod TextDocumentFormatting where - pluginEnabled _ pid conf = (PluginId $ formattingProvider conf) == pid - combineResponses _ _ _ _ (x :| _) = x - -instance PluginMethod TextDocumentRangeFormatting where - pluginEnabled _ pid conf = (PluginId $ formattingProvider conf) == pid - combineResponses _ _ _ _ (x :| _) = x - -instance PluginMethod TextDocumentPrepareCallHierarchy where - pluginEnabled _ = pluginEnabledConfig plcCallHierarchyOn - -instance PluginMethod TextDocumentSelectionRange where - pluginEnabled _ = pluginEnabledConfig plcSelectionRangeOn - combineResponses _ _ _ _ (x :| _) = x - -instance PluginMethod CallHierarchyIncomingCalls where - pluginEnabled _ = pluginEnabledConfig plcCallHierarchyOn - -instance PluginMethod CallHierarchyOutgoingCalls where - pluginEnabled _ = pluginEnabledConfig plcCallHierarchyOn - -instance PluginMethod CustomMethod where - pluginEnabled _ _ _ = True - combineResponses _ _ _ _ (x :| _) = x - --- --------------------------------------------------------------------- - --- | Methods which have a PluginMethod instance -data IdeMethod (m :: Method FromClient Request) = PluginMethod m => IdeMethod (SMethod m) -instance GEq IdeMethod where - geq (IdeMethod a) (IdeMethod b) = geq a b -instance GCompare IdeMethod where - gcompare (IdeMethod a) (IdeMethod b) = gcompare a b - --- | Methods which have a PluginMethod instance -data IdeNotification (m :: Method FromClient Notification) = HasTracing (MessageParams m) => IdeNotification (SMethod m) -instance GEq IdeNotification where - geq (IdeNotification a) (IdeNotification b) = geq a b -instance GCompare IdeNotification where - gcompare (IdeNotification a) (IdeNotification b) = gcompare a b - --- | Combine handlers for the -newtype PluginHandler a (m :: Method FromClient Request) - = PluginHandler (PluginId -> a -> MessageParams m -> LspM Config (NonEmpty (Either ResponseError (ResponseResult m)))) - -newtype PluginNotificationHandler a (m :: Method FromClient Notification) - = PluginNotificationHandler (PluginId -> a -> 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 - :: PluginMethod m - => SClientMethod m - -> PluginMethodHandler ideState m - -> PluginHandlers ideState -mkPluginHandler m f = PluginHandlers $ DMap.singleton (IdeMethod m) (PluginHandler f') - where - f' pid ide params = pure <$> f ide pid params - --- | Make a handler for plugins with no extra data -mkPluginNotificationHandler - :: HasTracing (MessageParams m) - => SClientMethod (m :: Method FromClient Notification) - -> PluginNotificationMethodHandler ideState m - -> PluginNotificationHandlers ideState -mkPluginNotificationHandler m f - = PluginNotificationHandlers $ DMap.singleton (IdeNotification m) (PluginNotificationHandler f') - where - f' pid ide vfs = f ide vfs pid - -defaultPluginDescriptor :: PluginId -> PluginDescriptor ideState -defaultPluginDescriptor plId = - PluginDescriptor - plId - mempty - mempty - mempty - defaultConfigDescriptor - mempty - mempty - Nothing - -newtype CommandId = CommandId T.Text - deriving (Show, Read, Eq, Ord) -instance IsString CommandId where - fromString = CommandId . T.pack - -data PluginCommand ideState = forall a. (FromJSON a) => - PluginCommand { commandId :: CommandId - , commandDesc :: T.Text - , commandFunc :: CommandFunction ideState a - } - --- --------------------------------------------------------------------- - -type CommandFunction ideState a - = ideState - -> a - -> LspM Config (Either ResponseError Value) - --- --------------------------------------------------------------------- - -newtype PluginId = PluginId T.Text - deriving (Show, Read, Eq, Ord) - -instance IsString PluginId where - fromString = PluginId . T.pack - -configForPlugin :: Config -> PluginId -> PluginConfig -configForPlugin config (PluginId plugin) - = Map.findWithDefault Data.Default.def plugin (plugins config) - --- | Checks that a given plugin is both enabled and the specific feature is --- enabled -pluginEnabledConfig :: (PluginConfig -> Bool) -> PluginId -> Config -> Bool -pluginEnabledConfig f pid config = plcGlobalOn pluginConfig && f pluginConfig - where - pluginConfig = configForPlugin config pid - --- --------------------------------------------------------------------- - --- | Format the given Text as a whole or only a @Range@ of it. --- Range must be relative to the text to format. --- To format the whole document, read the Text from the file and use 'FormatText' --- as the FormattingType. -data FormattingType = FormatText - | FormatRange Range - - -type FormattingMethod m = - ( J.HasOptions (MessageParams m) FormattingOptions - , J.HasTextDocument (MessageParams m) TextDocumentIdentifier - , ResponseResult m ~ List TextEdit - ) - -type FormattingHandler a - = a - -> FormattingType - -> T.Text - -> NormalizedFilePath - -> FormattingOptions - -> LspM Config (Either ResponseError (List TextEdit)) - -mkFormattingHandlers :: forall a. FormattingHandler a -> PluginHandlers a -mkFormattingHandlers f = mkPluginHandler STextDocumentFormatting (provider STextDocumentFormatting) - <> mkPluginHandler STextDocumentRangeFormatting (provider STextDocumentRangeFormatting) - where - provider :: forall m. FormattingMethod m => SMethod m -> PluginMethodHandler a m - provider m ide _pid params - | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = do - mf <- getVirtualFile $ toNormalizedUri uri - case mf of - Just vf -> do - let typ = case m of - STextDocumentFormatting -> FormatText - STextDocumentRangeFormatting -> FormatRange (params ^. J.range) - _ -> error "mkFormattingHandlers: impossible" - f ide typ (virtualFileText vf) nfp opts - Nothing -> pure $ Left $ responseError $ T.pack $ "Formatter plugin: could not get file contents for " ++ show uri - - | otherwise = pure $ Left $ responseError $ T.pack $ "Formatter plugin: uriToFilePath failed for: " ++ show uri - where - uri = params ^. J.textDocument . J.uri - opts = params ^. J.options - --- --------------------------------------------------------------------- - -responseError :: T.Text -> ResponseError -responseError txt = ResponseError InvalidParams txt Nothing - --- --------------------------------------------------------------------- - -data FallbackCodeActionParams = - FallbackCodeActionParams - { fallbackWorkspaceEdit :: Maybe WorkspaceEdit - , fallbackCommand :: Maybe Command - } - deriving (Generic, ToJSON, FromJSON) - --- --------------------------------------------------------------------- - -otSetUri :: SpanInFlight -> Uri -> IO () -otSetUri sp (Uri t) = setTag sp "uri" (encodeUtf8 t) - -class HasTracing a where - traceWithSpan :: SpanInFlight -> a -> IO () - traceWithSpan _ _ = pure () - -instance {-# OVERLAPPABLE #-} (HasTextDocument a doc, HasUri doc Uri) => HasTracing a where - traceWithSpan sp a = otSetUri sp (a ^. J.textDocument . J.uri) - -instance HasTracing Value -instance HasTracing ExecuteCommandParams -instance HasTracing DidChangeWatchedFilesParams 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 - --- --------------------------------------------------------------------- - -{-# 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 _ = "" + +-- --------------------------------------------------------------------- + +-- | 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. + -} diff --git a/test/Ide/PluginUtilsTest.hs b/test/Ide/PluginUtilsTest.hs --- a/test/Ide/PluginUtilsTest.hs +++ b/test/Ide/PluginUtilsTest.hs @@ -1,27 +1,205 @@ +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-orphans #-} + module Ide.PluginUtilsTest ( tests ) where -import Ide.PluginUtils (positionInRange) -import Language.LSP.Types (Position (Position), Range (Range)) +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" - [ positionInRangeTest + [ unescapeTest + , extractTextInRangeTest + , localOption (QuickCheckMaxSize 10000) $ + testProperty "RangeMap-List filtering identical" $ + prop_rangemapListEq @Int + , propertyTest ] -positionInRangeTest :: TestTree -positionInRangeTest = testGroup "positionInRange" - [ testCase "single line, after the end" $ - positionInRange (Position 1 10) (Range (Position 1 1) (Position 1 3)) @?= False - , testCase "single line, before the begining" $ - positionInRange (Position 1 0) (Range (Position 1 1) (Position 1 6)) @?= False - , testCase "single line, in range" $ - positionInRange (Position 1 5) (Range (Position 1 1) (Position 1 6)) @?= True - , testCase "multiline, in range" $ - positionInRange (Position 3 5) (Range (Position 1 1) (Position 5 6)) @?= True - , testCase "multiline, out of range" $ - positionInRange (Position 3 5) (Range (Position 3 6) (Position 4 10)) @?= False +unescapeTest :: TestTree +unescapeTest = testGroup "unescape" + [ testCase "no double quote" $ + unescape "hello世界" @?= "hello世界" + , testCase "whole string quoted" $ + unescape "\"hello\\19990\\30028\"" @?= "\"hello世界\"" + , testCase "text before quotes should not be unescaped" $ + unescape "\\19990a\"hello\\30028\"" @?= "\\19990a\"hello界\"" + , testCase "some text after quotes" $ + unescape "\"hello\\19990\\30028\"abc" @?= "\"hello世界\"abc" + , testCase "many pairs of quote" $ + unescape "oo\"hello\\19990\\30028\"abc\"\1087\1088\1080\1074\1077\1090\"hh" @?= "oo\"hello世界\"abc\"привет\"hh" + , testCase "double quote itself should not be unescaped" $ + unescape "\"\\\"\\19990o\"" @?= "\"\\\"世o\"" + , testCase "control characters should not be escaped" $ + 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 ] + +genRangeInline :: Gen Range +genRangeInline = do + x1 <- genPosition + delta <- genRangeLength + let x2 = x1 { _character = _character x1 + delta } + pure $ Range x1 x2 + where + genRangeLength :: Gen UInt + genRangeLength = uInt (5, 50) + +genRangeMultiline :: Gen Range +genRangeMultiline = do + x1 <- genPosition + let heightDelta = 1 + secondX <- genSecond + let x2 = x1 { _line = _line x1 + heightDelta + , _character = secondX + } + pure $ Range x1 x2 + where + genSecond :: Gen UInt + genSecond = uInt (0, 10) + +genPosition :: Gen Position +genPosition = Position + <$> 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, 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) + in classify (null filteredList) "no matches" $ + 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) diff --git a/test/Ide/TypesTests.hs b/test/Ide/TypesTests.hs new file mode 100644 --- /dev/null +++ b/test/Ide/TypesTests.hs @@ -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) diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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 ]