hls-plugin-api 1.5.0.0 → 1.6.0.0

raw patch · 8 files changed

+535/−179 lines, 8 filesdep +criteriondep +deepseqdep +hw-fingertreedep −processdep ~basedep ~hls-graphPVP ok

version bump matches the API change (PVP)

Dependencies added: criterion, deepseq, hw-fingertree, megaparsec, random, random-fu, tasty-quickcheck

Dependencies removed: process

Dependency ranges changed: base, hls-graph

API changes (from Hackage documentation)

Files

• bench/Main.hs +56/−0
• hls-plugin-api.cabal +40/−3
• src/Ide/Plugin/Config.hs +31/−106
• src/Ide/Plugin/ConfigUtils.hs +20/−18
• src/Ide/Plugin/RangeMap.hs +83/−0
• src/Ide/PluginUtils.hs +66/−8
• src/Ide/Types.hs +163/−41
• test/Ide/PluginUtilsTest.hs +76/−3

@@ -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+        ]+    ]

@@ -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 <https://github.com/haskell/haskell-language-server#readme>@@ -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

@@ -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  -- ---------------------------------------------------------------------

@@ -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

@@ -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

@@ -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' <> "\""

@@ -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  -- --------------------------------------------------------------------- 

@@ -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