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.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.5.0.0 +version: 1.6.0.0 synopsis: Haskell Language Server API for plugin communication description: Please see the README on GitHub at @@ -20,6 +20,14 @@ 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 @@ -29,6 +37,7 @@ Ide.Plugin.Config Ide.Plugin.ConfigUtils Ide.Plugin.Properties + Ide.Plugin.RangeMap Ide.PluginUtils Ide.Types @@ -46,17 +55,17 @@ , filepath , ghc , hashable - , hls-graph ^>= 1.8 + , hls-graph ^>= 1.9 , lens , lens-aeson , lsp ^>=1.6.0.0 , opentelemetry >=0.4 , optparse-applicative - , process , regex-tdfa >=1.3.1.0 , text , transformers , unordered-containers + , megaparsec > 9 if os(windows) build-depends: Win32 @@ -70,7 +79,13 @@ if flag(pedantic) ghc-options: -Werror + if impl(ghc >= 9) + ghc-options: -Wunused-packages + if flag(use-fingertree) + cpp-options: -DUSE_FINGERTREE + build-depends: hw-fingertree + default-language: Haskell2010 default-extensions: DataKinds @@ -90,4 +105,26 @@ , tasty , tasty-hunit , tasty-rerun + , tasty-quickcheck + , text , lsp-types + , containers + +benchmark rangemap-benchmark + -- Benchmark doesn't make sense if fingertree implementation + -- is not used. + if !flag(use-fingertree) + buildable: False + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: bench + main-is: Main.hs + ghc-options: -threaded -Wall + build-depends: + base + , hls-plugin-api + , lsp-types + , criterion + , random + , random-fu + , deepseq 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,8 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} module Ide.Plugin.Config ( getConfigFromNotification , Config(..) @@ -14,61 +12,32 @@ ) where import Control.Applicative +import Control.Lens (preview) import Data.Aeson hiding (Error) import qualified Data.Aeson as A +import Data.Aeson.Lens (_String) import qualified Data.Aeson.Types as A import Data.Default -import qualified Data.Map as Map +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe) import qualified Data.Text as T -import GHC.Generics (Generic) +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 = - 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 +parseConfig :: IdePlugins s -> Config -> Value -> A.Parser Config +parseConfig idePlugins defValue = A.withObject "Config" $ \v -> do -- Officially, we use "haskell" as the section name but for -- backwards compatibility we also accept "languageServerHaskell" c <- v .: "haskell" <|> v .:? "languageServerHaskell" @@ -78,74 +47,29 @@ <$> (o .:? "checkParents" <|> v .:? "checkParents") .!= checkParents defValue <*> (o .:? "checkProject" <|> v .:? "checkProject") .!= checkProject defValue <*> o .:? "formattingProvider" .!= formattingProvider defValue + <*> o .:? "cabalFormattingProvider" .!= cabalFormattingProvider defValue <*> o .:? "maxCompletions" .!= maxCompletions defValue - <*> o .:? "plugin" .!= plugins 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 @@ -156,6 +80,7 @@ <*> o .:? "completionOn" .!= plcCompletionOn def <*> o .:? "renameOn" .!= plcRenameOn def <*> o .:? "selectionRangeOn" .!= plcSelectionRangeOn def + <*> o .:? "foldingRangeOn" .!= plcFoldingRangeOn 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 @@ -9,10 +9,10 @@ import qualified Data.Aeson as A import Data.Aeson.Lens (_Object) import qualified Data.Aeson.Types as A -import Data.Default (def) +import Data.Default import qualified Data.Dependent.Map as DMap import qualified Data.Dependent.Sum as DSum -import Data.List (nub) +import Data.List.Extra (nubOrd) import Data.String (IsString (fromString)) import qualified Data.Text as T import Ide.Plugin.Config @@ -62,12 +62,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 don't produce globalOn at all + [_] -> ["globalOn" A..= plcGlobalOn configInitialGenericConfig] + _ -> x -- Example: -- -- { @@ -82,15 +84,15 @@ (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 + STextDocumentCodeAction -> ["codeActionsOn" A..= plcCodeActionsOn] + STextDocumentCodeLens -> ["codeLensOn" A..= plcCodeLensOn] + STextDocumentRename -> ["renameOn" A..= plcRenameOn] + STextDocumentHover -> ["hoverOn" A..= plcHoverOn] + STextDocumentDocumentSymbol -> ["symbolsOn" A..= plcSymbolsOn] + STextDocumentCompletion -> ["completionOn" A..= plcCompletionOn] + STextDocumentPrepareCallHierarchy -> ["callHierarchyOn" A..= plcCallHierarchyOn] _ -> [] -- | Generates json schema used in haskell vscode extension @@ -106,7 +108,7 @@ genericSchema = let x = [toKey' "diagnosticsOn" A..= schemaEntry "diagnostics" | configHasDiagnostics] - <> nub (mconcat (handlersToGenericSchema <$> handlers)) + <> nubOrd (mconcat (handlersToGenericSchema <$> 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 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,83 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | 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, + ) where + +import Data.Bifunctor (first) +import Data.Foldable (foldl') +import Development.IDE.Graph.Classes (NFData) +import Language.LSP.Types (Position, + Range (Range), + isSubrangeOf) +#ifdef USE_FINGERTREE +import qualified HaskellWorks.Data.IntervalMap.FingerTree as IM +#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 + +#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/PluginUtils.hs b/src/Ide/PluginUtils.hs --- a/src/Ide/PluginUtils.hs +++ b/src/Ide/PluginUtils.hs @@ -2,9 +2,12 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} module Ide.PluginUtils - ( WithDeletions(..), - getProcessID, + ( -- * LSP Range manipulation functions normalize, + extendNextLine, + extendLineStart, + WithDeletions(..), + getProcessID, makeDiffTextEdit, makeDiffTextEditAdditive, diffText, @@ -32,6 +35,7 @@ handleMaybe, handleMaybeM, throwPluginError, + unescape, ) where @@ -43,10 +47,12 @@ import Data.Algorithm.Diff import Data.Algorithm.DiffOutput import Data.Bifunctor (Bifunctor (first)) +import Data.Char (isPrint, showLitChar) +import Data.Functor (void) import qualified Data.HashMap.Strict as H -import Data.List (find) import Data.String (IsString (fromString)) import qualified Data.Text as T +import Data.Void (Void) import Ide.Plugin.Config import Ide.Plugin.Properties import Ide.Types @@ -57,14 +63,35 @@ SemanticTokensEdit (_start)) import qualified Language.LSP.Types as J import Language.LSP.Types.Capabilities +import qualified Text.Megaparsec as P +import qualified Text.Megaparsec.Char as P +import qualified Text.Megaparsec.Char.Lexer as P -- --------------------------------------------------------------------- -- | 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 + -- --------------------------------------------------------------------- data WithDeletions = IncludeDeletions | SkipDeletions @@ -167,7 +194,7 @@ -- --------------------------------------------------------------------- -- | 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 @@ -178,7 +205,7 @@ -- | 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 @@ -189,7 +216,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 @@ -255,3 +282,34 @@ pluginResponse = fmap (first (\msg -> ResponseError InternalError (fromString msg) Nothing)) . runExceptT + +-- --------------------------------------------------------------------- + +type TextParser = P.Parsec Void T.Text + +-- | 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 + +-- | 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' <> "\"" diff --git a/src/Ide/Types.hs b/src/Ide/Types.hs --- a/src/Ide/Types.hs +++ b/src/Ide/Types.hs @@ -28,6 +28,7 @@ , IdeNotification(..) , IdePlugins(IdePlugins, ipMap) , DynFlagsModifications(..) +, Config(..), PluginConfig(..), CheckParents(..) , ConfigDescriptor(..), defaultConfigDescriptor, configForPlugin, pluginEnabledConfig , CustomConfig(..), mkCustomConfig , FallbackCodeActionParams(..) @@ -56,10 +57,11 @@ import qualified System.Posix.Process as P (getProcessID) import System.Posix.Signals #endif +import Control.Applicative ((<|>)) import Control.Arrow ((&&&)) -import Control.Lens ((^.)) +import Control.Lens ((^.), (.~)) import Data.Aeson hiding (defaultOptions) -import qualified Data.Default +import Data.Default import Data.Dependent.Map (DMap) import qualified Data.Dependent.Map as DMap import qualified Data.DList as DList @@ -67,7 +69,7 @@ import Data.Hashable (Hashable) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap -import Data.List.Extra (sortOn, find) +import Data.List.Extra (find, sortOn) import Data.List.NonEmpty (NonEmpty (..), toList) import qualified Data.Map as Map import Data.Maybe @@ -79,7 +81,6 @@ 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 @@ -88,6 +89,7 @@ SemanticTokensEdit (_start)) import Language.LSP.Types.Capabilities (ClientCapabilities (ClientCapabilities), TextDocumentClientCapabilities (_codeAction, _documentSymbol)) +import qualified Language.LSP.Types.Lens as J import Language.LSP.Types.Lens as J (HasChildren (children), HasCommand (command), HasContents (contents), @@ -107,12 +109,11 @@ import System.FilePath import System.IO.Unsafe import Text.Regex.TDFA.Text () -import Control.Applicative ((<|>)) -- --------------------------------------------------------------------- data IdePlugins ideState = IdePlugins_ - { ipMap_ :: HashMap PluginId (PluginDescriptor ideState) + { ipMap_ :: HashMap PluginId (PluginDescriptor ideState) , lookupCommandProvider :: CommandId -> Maybe PluginId } @@ -167,6 +168,107 @@ -- --------------------------------------------------------------------- +-- | We (initially anyway) mirror the hie configuration, so that existing +-- clients can simply switch executable and not have any nasty surprises. There +-- will be surprises relating to config options being ignored, initially though. +data Config = + Config + { checkParents :: CheckParents + , checkProject :: !Bool + , formattingProvider :: !T.Text + , cabalFormattingProvider :: !T.Text + , maxCompletions :: !Int + , plugins :: !(Map.Map PluginId PluginConfig) + } deriving (Show,Eq) + +instance ToJSON Config where + toJSON Config{..} = + object [ "haskell" .= r ] + where + r = object [ "checkParents" .= checkParents + , "checkProject" .= checkProject + , "formattingProvider" .= formattingProvider + , "maxCompletions" .= maxCompletions + , "plugin" .= Map.mapKeysMonotonic (\(PluginId p) -> p) plugins + ] + +instance Default Config where + def = Config + { checkParents = CheckOnSave + , checkProject = True + -- , formattingProvider = "brittany" + , formattingProvider = "ormolu" + -- , formattingProvider = "floskell" + -- , formattingProvider = "stylish-haskell" + , cabalFormattingProvider = "cabal-fmt" + , maxCompletions = 40 + , plugins = mempty + } + +data CheckParents + -- Note that ordering of constructors is meaningful and must be monotonically + -- increasing in the scenarios where parents are checked + = NeverCheck + | CheckOnSave + | AlwaysCheck + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (FromJSON, ToJSON) + +-- | A PluginConfig is a generic configuration for a given HLS plugin. It +-- provides a "big switch" to turn it on or off as a whole, as well as small +-- switches per feature, and a slot for custom config. +-- This provides a regular naming scheme for all plugin config. +data PluginConfig = + PluginConfig + { plcGlobalOn :: !Bool + , plcCallHierarchyOn :: !Bool + , plcCodeActionsOn :: !Bool + , plcCodeLensOn :: !Bool + , plcDiagnosticsOn :: !Bool + , plcHoverOn :: !Bool + , plcSymbolsOn :: !Bool + , plcCompletionOn :: !Bool + , plcRenameOn :: !Bool + , plcSelectionRangeOn :: !Bool + , plcFoldingRangeOn :: !Bool + , plcConfig :: !Object + } deriving (Show,Eq) + +instance Default PluginConfig where + def = PluginConfig + { plcGlobalOn = True + , plcCallHierarchyOn = True + , plcCodeActionsOn = True + , plcCodeLensOn = True + , plcDiagnosticsOn = True + , plcHoverOn = True + , plcSymbolsOn = True + , plcCompletionOn = True + , plcRenameOn = True + , plcSelectionRangeOn = True + , plcFoldingRangeOn = True + , plcConfig = mempty + } + +instance ToJSON PluginConfig where + toJSON (PluginConfig g ch ca cl d h s c rn sr fr cfg) = r + where + r = object [ "globalOn" .= g + , "callHierarchyOn" .= ch + , "codeActionsOn" .= ca + , "codeLensOn" .= cl + , "diagnosticsOn" .= d + , "hoverOn" .= h + , "symbolsOn" .= s + , "completionOn" .= c + , "renameOn" .= rn + , "selectionRangeOn" .= sr + , "foldingRangeOn" .= fr + , "config" .= cfg + ] + +-- --------------------------------------------------------------------- + data PluginDescriptor (ideState :: *) = PluginDescriptor { pluginId :: !PluginId -- ^ Unique identifier of the plugin. @@ -220,21 +322,22 @@ -- 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, + -- | 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, + configHasDiagnostics :: Bool, -- | Custom config. - configCustomConfig :: CustomConfig + configCustomConfig :: CustomConfig } mkCustomConfig :: Properties r -> CustomConfig mkCustomConfig = CustomConfig defaultConfigDescriptor :: ConfigDescriptor -defaultConfigDescriptor = ConfigDescriptor True False (mkCustomConfig emptyProperties) +defaultConfigDescriptor = + ConfigDescriptor Data.Default.def False (mkCustomConfig emptyProperties) -- | Methods that can be handled by plugins. -- 'ExtraParams' captures any extra data the IDE passes to the handlers for this method @@ -281,7 +384,7 @@ default pluginEnabled :: (HasTextDocument (MessageParams m) doc, HasUri doc Uri) => SMethod m -> MessageParams m -> PluginDescriptor c -> Config -> Bool - pluginEnabled _ params desc conf = pluginResponsible uri desc && plcGlobalOn (configForPlugin conf (pluginId desc)) + pluginEnabled _ params desc conf = pluginResponsible uri desc && plcGlobalOn (configForPlugin conf desc) where uri = params ^. J.textDocument . J.uri @@ -313,7 +416,7 @@ instance PluginMethod Request TextDocumentCodeAction where pluginEnabled _ msgParams pluginDesc config = - pluginResponsible uri pluginDesc && pluginEnabledConfig plcCodeActionsOn (pluginId pluginDesc) config + pluginResponsible uri pluginDesc && pluginEnabledConfig plcCodeActionsOn (configForPlugin config pluginDesc) where uri = msgParams ^. J.textDocument . J.uri @@ -374,72 +477,76 @@ instance PluginMethod Request TextDocumentCodeLens where pluginEnabled _ msgParams pluginDesc config = pluginResponsible uri pluginDesc - && pluginEnabledConfig plcCodeLensOn (pluginId pluginDesc) config + && pluginEnabledConfig plcCodeLensOn (configForPlugin config pluginDesc) where uri = msgParams ^. J.textDocument . J.uri instance PluginMethod Request TextDocumentRename where pluginEnabled _ msgParams pluginDesc config = pluginResponsible uri pluginDesc - && pluginEnabledConfig plcRenameOn (pluginId pluginDesc) config + && pluginEnabledConfig plcRenameOn (configForPlugin config pluginDesc) where uri = msgParams ^. J.textDocument . J.uri instance PluginMethod Request TextDocumentHover where pluginEnabled _ msgParams pluginDesc config = pluginResponsible uri pluginDesc - && pluginEnabledConfig plcHoverOn (pluginId pluginDesc) config + && pluginEnabledConfig plcHoverOn (configForPlugin config pluginDesc) where uri = msgParams ^. J.textDocument . J.uri instance PluginMethod Request TextDocumentDocumentSymbol where pluginEnabled _ msgParams pluginDesc config = pluginResponsible uri pluginDesc - && pluginEnabledConfig plcSymbolsOn (pluginId pluginDesc) config + && pluginEnabledConfig plcSymbolsOn (configForPlugin config pluginDesc) where uri = msgParams ^. J.textDocument . J.uri +instance PluginMethod Request CompletionItemResolve where + pluginEnabled _ msgParams pluginDesc config = pluginEnabledConfig plcCompletionOn (configForPlugin config pluginDesc) + instance PluginMethod Request TextDocumentCompletion where pluginEnabled _ msgParams pluginDesc config = pluginResponsible uri pluginDesc - && pluginEnabledConfig plcCompletionOn (pluginId pluginDesc) config + && pluginEnabledConfig plcCompletionOn (configForPlugin config pluginDesc) where uri = msgParams ^. J.textDocument . J.uri instance PluginMethod Request TextDocumentFormatting where pluginEnabled STextDocumentFormatting msgParams pluginDesc conf = - pluginResponsible uri pluginDesc && PluginId (formattingProvider conf) == pid + pluginResponsible uri pluginDesc + && (PluginId (formattingProvider conf) == pid || PluginId (cabalFormattingProvider conf) == pid) where uri = msgParams ^. J.textDocument . J.uri pid = pluginId pluginDesc instance PluginMethod Request TextDocumentRangeFormatting where pluginEnabled _ msgParams pluginDesc conf = pluginResponsible uri pluginDesc - && PluginId (formattingProvider conf) == pid + && (PluginId (formattingProvider conf) == pid || PluginId (cabalFormattingProvider conf) == pid) where uri = msgParams ^. J.textDocument . J.uri pid = pluginId pluginDesc instance PluginMethod Request TextDocumentPrepareCallHierarchy where pluginEnabled _ msgParams pluginDesc conf = pluginResponsible uri pluginDesc - && pluginEnabledConfig plcCallHierarchyOn pid conf + && pluginEnabledConfig plcCallHierarchyOn (configForPlugin conf pluginDesc) where uri = msgParams ^. J.textDocument . J.uri - pid = pluginId pluginDesc instance PluginMethod Request TextDocumentSelectionRange where pluginEnabled _ msgParams pluginDesc conf = pluginResponsible uri pluginDesc - && pluginEnabledConfig plcSelectionRangeOn pid conf + && pluginEnabledConfig plcSelectionRangeOn (configForPlugin conf pluginDesc) where uri = msgParams ^. J.textDocument . J.uri - pid = pluginId pluginDesc +instance PluginMethod Request TextDocumentFoldingRange where + pluginEnabled _ msgParams pluginDesc conf = pluginResponsible uri pluginDesc + && pluginEnabledConfig plcFoldingRangeOn (configForPlugin conf pluginDesc) + where + uri = msgParams ^. J.textDocument . J.uri + instance PluginMethod Request CallHierarchyIncomingCalls where -- This method has no URI parameter, thus no call to 'pluginResponsible' - pluginEnabled _ _ pluginDesc conf = pluginEnabledConfig plcCallHierarchyOn pid conf - where - pid = pluginId pluginDesc + pluginEnabled _ _ pluginDesc conf = pluginEnabledConfig plcCallHierarchyOn (configForPlugin conf pluginDesc) instance PluginMethod Request CallHierarchyOutgoingCalls where -- This method has no URI parameter, thus no call to 'pluginResponsible' - pluginEnabled _ _ pluginDesc conf = pluginEnabledConfig plcCallHierarchyOn pid conf - where - pid = pluginId pluginDesc + pluginEnabled _ _ pluginDesc conf = pluginEnabledConfig plcCallHierarchyOn (configForPlugin conf pluginDesc) instance PluginMethod Request CustomMethod where pluginEnabled _ _ _ _ = True @@ -490,6 +597,18 @@ si = SymbolInformation name' (ds ^. kind) Nothing (ds ^. deprecated) loc parent in [si] <> children' +instance PluginRequestMethod CompletionItemResolve where + -- resolving completions can only change the detail, additionalTextEdit or documentation fields + combineResponses _ _ _ _ (x :| xs) = go x xs + where go :: CompletionItem -> [CompletionItem] -> CompletionItem + go !comp [] = comp + go !comp1 (comp2:xs) + = go (comp1 + & J.detail .~ comp1 ^. J.detail <> comp2 ^. J.detail + & J.documentation .~ ((comp1 ^. J.documentation) <|> (comp2 ^. J.documentation)) -- difficult to write generic concatentation for docs + & J.additionalTextEdits .~ comp1 ^. J.additionalTextEdits <> comp2 ^. J.additionalTextEdits) + xs + instance PluginRequestMethod TextDocumentCompletion where combineResponses _ conf _ _ (toList -> xs) = snd $ consumeCompletionResponse limit $ combine xs where @@ -529,6 +648,9 @@ instance PluginRequestMethod TextDocumentSelectionRange where combineResponses _ _ _ _ (x :| _) = x +instance PluginRequestMethod TextDocumentFoldingRange where + combineResponses _ _ _ _ x = sconcat x + instance PluginRequestMethod CallHierarchyIncomingCalls where instance PluginRequestMethod CallHierarchyOutgoingCalls where @@ -555,19 +677,19 @@ instance PluginMethod Notification WorkspaceDidChangeWatchedFiles where -- This method has no URI parameter, thus no call to 'pluginResponsible'. - pluginEnabled _ _ desc conf = plcGlobalOn $ configForPlugin conf (pluginId desc) + pluginEnabled _ _ desc conf = plcGlobalOn $ configForPlugin conf desc instance PluginMethod Notification WorkspaceDidChangeWorkspaceFolders where -- This method has no URI parameter, thus no call to 'pluginResponsible'. - pluginEnabled _ _ desc conf = plcGlobalOn $ configForPlugin conf (pluginId desc) + pluginEnabled _ _ desc conf = plcGlobalOn $ configForPlugin conf desc instance PluginMethod Notification WorkspaceDidChangeConfiguration where -- This method has no URI parameter, thus no call to 'pluginResponsible'. - pluginEnabled _ _ desc conf = plcGlobalOn $ configForPlugin conf (pluginId desc) + pluginEnabled _ _ desc conf = plcGlobalOn $ configForPlugin conf desc instance PluginMethod Notification Initialized where -- This method has no URI parameter, thus no call to 'pluginResponsible'. - pluginEnabled _ _ desc conf = plcGlobalOn $ configForPlugin conf (pluginId desc) + pluginEnabled _ _ desc conf = plcGlobalOn $ configForPlugin conf desc instance PluginNotificationMethod TextDocumentDidOpen where @@ -727,16 +849,15 @@ instance IsString PluginId where fromString = PluginId . T.pack -configForPlugin :: Config -> PluginId -> PluginConfig -configForPlugin config (PluginId plugin) - = Map.findWithDefault Data.Default.def plugin (plugins config) +-- | Lookup the current config for a plugin +configForPlugin :: Config -> PluginDescriptor c -> PluginConfig +configForPlugin config PluginDescriptor{..} + = Map.findWithDefault (configInitialGenericConfig pluginConfigDescriptor) pluginId (plugins config) -- | Checks that a given plugin is both enabled and the specific feature is -- enabled -pluginEnabledConfig :: (PluginConfig -> Bool) -> PluginId -> Config -> Bool -pluginEnabledConfig f pid config = plcGlobalOn pluginConfig && f pluginConfig - where - pluginConfig = configForPlugin config pid +pluginEnabledConfig :: (PluginConfig -> Bool) -> PluginConfig -> Bool +pluginEnabledConfig f pluginConfig = plcGlobalOn pluginConfig && f pluginConfig -- --------------------------------------------------------------------- @@ -823,6 +944,7 @@ traceWithSpan sp (WorkspaceSymbolParams _ _ query) = setTag sp "query" (encodeUtf8 query) instance HasTracing CallHierarchyIncomingCallsParams instance HasTracing CallHierarchyOutgoingCallsParams +instance HasTracing CompletionItem -- --------------------------------------------------------------------- diff --git a/test/Ide/PluginUtilsTest.hs b/test/Ide/PluginUtilsTest.hs --- a/test/Ide/PluginUtilsTest.hs +++ b/test/Ide/PluginUtilsTest.hs @@ -1,13 +1,86 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + module Ide.PluginUtilsTest ( tests ) where -import Ide.PluginUtils (positionInRange) -import Language.LSP.Types (Position (Position), Range (Range)) +import Data.Char (isPrint) +import qualified Data.Set as Set +import qualified Data.Text as T +import qualified Ide.Plugin.RangeMap as RangeMap +import Ide.PluginUtils (positionInRange, unescape) +import Language.LSP.Types (Position (..), Range (Range), UInt, + isSubrangeOf) import Test.Tasty import Test.Tasty.HUnit +import Test.Tasty.QuickCheck tests :: TestTree tests = testGroup "PluginUtils" - [ + [ unescapeTest + , localOption (QuickCheckMaxSize 10000) $ + testProperty "RangeMap-List filtering identical" $ + prop_rangemapListEq @Int ] + +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\"" + ] + +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 = fromInteger <$> chooseInteger (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 = fromInteger <$> chooseInteger (0, 10) + +genPosition :: Gen Position +genPosition = Position + <$> (fromInteger <$> chooseInteger (0, 1000)) + <*> (fromInteger <$> chooseInteger (0, 150)) + +instance Arbitrary Range where + arbitrary = genRange + +prop_rangemapListEq :: (Show a, Eq 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