hls-plugin-api 2.6.0.0 → 2.14.0.0
raw patch · 13 files changed
Files
- bench/Main.hs +9/−9
- hls-plugin-api.cabal +19/−15
- src/Ide/Logger.hs +5/−38
- src/Ide/Plugin/Config.hs +6/−4
- src/Ide/Plugin/ConfigUtils.hs +114/−7
- src/Ide/Plugin/Error.hs +2/−3
- src/Ide/Plugin/Properties.hs +117/−15
- src/Ide/Plugin/RangeMap.hs +21/−11
- src/Ide/Plugin/Resolve.hs +25/−36
- src/Ide/PluginUtils.hs +28/−2
- src/Ide/Types.hs +212/−100
- test/Ide/PluginUtilsTest.hs +75/−9
- test/Ide/TypesTests.hs +20/−16
bench/Main.hs view
@@ -2,17 +2,17 @@ -- vs RangeMap-based "in-range filtering" approaches module Main (main) where -import Control.DeepSeq (force)-import Control.Exception (evaluate)-import Control.Monad (replicateM)+import Control.DeepSeq (force)+import Control.Exception (evaluate)+import Control.Monad (replicateM) import qualified Criterion import qualified Criterion.Main-import Data.Random (RVar)-import qualified Data.Random as Fu-import qualified Ide.Plugin.RangeMap as RangeMap-import Language.LSP.Types (Position (..), Range (..), UInt,- isSubrangeOf)-import qualified System.Random.Stateful as Random+import Data.Random (RVar)+import qualified Data.Random as Fu+import qualified Ide.Plugin.RangeMap as RangeMap+import Language.LSP.Protocol.Types (Position (..), Range (..), UInt,+ isSubrangeOf)+import qualified System.Random.Stateful as Random genRangeList :: Int -> RVar [Range]
hls-plugin-api.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-plugin-api-version: 2.6.0.0+version: 2.14.0.0 synopsis: Haskell Language Server API for plugin communication description: Please see the README on GitHub at <https://github.com/haskell/haskell-language-server#readme>@@ -32,7 +32,13 @@ 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@@ -54,23 +60,22 @@ , data-default , dependent-map , dependent-sum >=0.7- , Diff ^>=0.4.0+ , Diff ^>=0.5 || ^>=1.0.0 , dlist , extra , filepath , ghc , hashable- , hls-graph == 2.6.0.0+ , hls-graph == 2.14.0.0 , lens , lens-aeson- , lsp ^>=2.3+ , lsp ^>=2.8 , megaparsec >=9.0 , mtl , opentelemetry >=0.4 , optparse-applicative , prettyprinter , regex-tdfa >=1.3.1.0- , row-types , stm , text , time@@ -84,10 +89,6 @@ else build-depends: unix - ghc-options:- -Wall -Wredundant-constraints -Wno-name-shadowing- -Wno-unticked-promoted-constructors -Wunused-packages- if flag(pedantic) ghc-options: -Werror @@ -95,15 +96,14 @@ cpp-options: -DUSE_FINGERTREE build-depends: hw-fingertree - default-language: Haskell2010+ default-language: GHC2021 default-extensions: DataKinds- KindSignatures- TypeOperators test-suite tests+ import: warnings type: exitcode-stdio-1.0- default-language: Haskell2010+ default-language: GHC2021 hs-source-dirs: test main-is: Main.hs ghc-options: -threaded -rtsopts -with-rtsopts=-N@@ -112,6 +112,8 @@ Ide.TypesTests build-depends:+ , bytestring+ , aeson , base , containers , data-default@@ -119,22 +121,24 @@ , 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: Haskell2010+ default-language: GHC2021 hs-source-dirs: bench main-is: Main.hs- ghc-options: -threaded -Wall+ ghc-options: -threaded build-depends: , base , criterion
src/Ide/Logger.hs view
@@ -1,23 +1,16 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 -{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-} -- | This is a compatibility module that abstracts over the -- concrete choice of logging framework so users can plug in whatever -- framework they want to. module Ide.Logger ( Priority(..)- , Logger(..) , Recorder(..)- , logError, logWarning, logInfo, logDebug- , noLogging , WithPriority(..) , logWith , cmap@@ -34,6 +27,7 @@ , module PrettyPrinterModule , renderStrict , toCologActionWithPrio+ , defaultLoggingColumns ) where import Colog.Core (LogAction (..), Severity,@@ -52,7 +46,6 @@ import Data.Functor.Contravariant (Contravariant (contramap)) import Data.Maybe (fromMaybe) import Data.Text (Text)-import qualified Data.Text as T import qualified Data.Text as Text import qualified Data.Text.IO as Text import Data.Time (defaultTimeLocale, formatTime,@@ -85,32 +78,6 @@ | Error -- ^ Such log messages must never occur in expected usage. deriving (Eq, Show, Read, Ord, Enum, Bounded) --- | Note that this is logging actions _of the program_, not of the user.--- You shouldn't call warning/error if the user has caused an error, only--- if our code has gone wrong and is itself erroneous (e.g. we threw an exception).-newtype Logger = Logger {logPriority :: Priority -> T.Text -> IO ()}--instance Semigroup Logger where- l1 <> l2 = Logger $ \p t -> logPriority l1 p t >> logPriority l2 p t--instance Monoid Logger where- mempty = Logger $ \_ _ -> pure ()--logError :: Logger -> T.Text -> IO ()-logError x = logPriority x Error--logWarning :: Logger -> T.Text -> IO ()-logWarning x = logPriority x Warning--logInfo :: Logger -> T.Text -> IO ()-logInfo x = logPriority x Info--logDebug :: Logger -> T.Text -> IO ()-logDebug x = logPriority x Debug--noLogging :: Logger-noLogging = Logger $ \_ _ -> return ()- data WithPriority a = WithPriority { priority :: Priority, callStack_ :: CallStack, payload :: a } deriving Functor -- | Note that this is logging actions _of the program_, not of the user.@@ -178,7 +145,7 @@ fileHandle :: Either IOException Handle <- liftIO $ try (openFile path AppendMode) case fileHandle of Left e -> action $ Left e- Right fileHandle -> finally ((Right <$> makeHandleRecorder fileHandle) >>= action) (liftIO $ hClose fileHandle)+ Right fileHandle -> finally (makeHandleRecorder fileHandle >>= action . Right) (liftIO $ hClose fileHandle) makeDefaultHandleRecorder :: MonadIO m
src/Ide/Plugin/Config.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-}@@ -43,6 +42,7 @@ <*> o .:? "formattingProvider" .!= formattingProvider defValue <*> o .:? "cabalFormattingProvider" .!= cabalFormattingProvider defValue <*> o .:? "maxCompletions" .!= maxCompletions defValue+ <*> o .:? "sessionLoading" .!= sessionLoading defValue <*> A.explicitParseFieldMaybe (parsePlugins idePlugins) o "plugin" .!= plugins defValue -- | Parse the 'PluginConfig'.@@ -63,19 +63,21 @@ -- --------------------------------------------------------------------- parsePluginConfig :: PluginConfig -> Value -> A.Parser PluginConfig-parsePluginConfig def = A.withObject "PluginConfig" $ \o -> PluginConfig+parsePluginConfig def = A.withObject "PluginConfig" $ \o -> PluginConfig <$> o .:? "globalOn" .!= plcGlobalOn def <*> o .:? "callHierarchyOn" .!= plcCallHierarchyOn def- <*> o .:? "semanticTokensOn" .!= plcSemanticTokensOn def <*> o .:? "codeActionsOn" .!= plcCodeActionsOn def <*> o .:? "codeLensOn" .!= plcCodeLensOn def+ <*> o .:? "inlayHintsOn" .!= plcInlayHintsOn def <*> o .:? "diagnosticsOn" .!= plcDiagnosticsOn def -- AZ <*> o .:? "hoverOn" .!= plcHoverOn def <*> o .:? "symbolsOn" .!= plcSymbolsOn def+ <*> o .:? "signatureHelpOn" .!= plcSignatureHelpOn def <*> o .:? "completionOn" .!= plcCompletionOn def <*> o .:? "renameOn" .!= plcRenameOn def <*> o .:? "selectionRangeOn" .!= plcSelectionRangeOn def- <*> o .:? "foldingRangeOn" .!= plcFoldingRangeOn def+ <*> o .:? "foldingRangeOn" .!= plcFoldingRangeOn def+ <*> o .:? "semanticTokensOn" .!= plcSemanticTokensOn def <*> o .:? "config" .!= plcConfig def -- ---------------------------------------------------------------------
src/Ide/Plugin/ConfigUtils.hs view
@@ -3,7 +3,11 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} -module Ide.Plugin.ConfigUtils where+module Ide.Plugin.ConfigUtils (+ pluginsToDefaultConfig,+ pluginsToVSCodeExtensionSchema,+ pluginsCustomConfigToMarkdownTables+ ) where import Control.Lens (at, (&), (?~)) import qualified Data.Aeson as A@@ -15,8 +19,15 @@ import Data.List.Extra (nubOrd) import Data.String (IsString (fromString)) import qualified Data.Text as T+import GHC.TypeLits (symbolVal) import Ide.Plugin.Config-import Ide.Plugin.Properties (toDefaultJSON,+import Ide.Plugin.Properties (KeyNameProxy, MetaData (..),+ PluginCustomConfig (..),+ PluginCustomConfigParam (..),+ Properties (..),+ SPropertyKey (..),+ SomePropertyKeyWithMetaData (..),+ toDefaultJSON, toVSCodeExtensionSchema) import Ide.Types import Language.LSP.Protocol.Message@@ -31,10 +42,10 @@ pluginsToDefaultConfig IdePlugins {..} = -- Use '_Object' and 'at' to get at the "plugin" key -- and actually set it.- A.toJSON defaultConfig & _Object . at "plugin" ?~ elems+ A.toJSON defaultConfig & _Object . at "plugin" ?~ pluginSpecificDefaultConfigs where- defaultConfig@Config {} = def- elems = A.object $ mconcat $ singlePlugin <$> ipMap+ defaultConfig = def :: Config+ pluginSpecificDefaultConfigs = A.object $ mconcat $ singlePlugin <$> ipMap -- Splice genericDefaultConfig and dedicatedDefaultConfig -- Example: --@@ -48,6 +59,7 @@ -- } -- } -- }+ singlePlugin :: PluginDescriptor ideState -> [A.Pair] singlePlugin PluginDescriptor {pluginConfigDescriptor = ConfigDescriptor {..}, ..} = let x = genericDefaultConfig <> dedicatedDefaultConfig in [fromString (T.unpack pId) A..= A.object x | not $ null x]@@ -66,8 +78,8 @@ <> nubOrd (mconcat (handlersToGenericDefaultConfig configInitialGenericConfig <$> handlers)) in case x of- -- if the plugin has only one capability, we produce globalOn instead of the specific one;- -- otherwise we don't produce globalOn at all+ -- If the plugin has only one capability, we produce globalOn instead of the specific one;+ -- otherwise we omit globalOn [_] -> ["globalOn" A..= plcGlobalOn configInitialGenericConfig] _ -> x -- Example:@@ -88,12 +100,15 @@ handlersToGenericDefaultConfig PluginConfig{..} (IdeMethod m DSum.:=> _) = case m of SMethod_TextDocumentCodeAction -> ["codeActionsOn" A..= plcCodeActionsOn] SMethod_TextDocumentCodeLens -> ["codeLensOn" A..= plcCodeLensOn]+ SMethod_TextDocumentInlayHint -> ["inlayHintsOn" A..= plcInlayHintsOn] SMethod_TextDocumentRename -> ["renameOn" A..= plcRenameOn] SMethod_TextDocumentHover -> ["hoverOn" A..= plcHoverOn] SMethod_TextDocumentDocumentSymbol -> ["symbolsOn" A..= plcSymbolsOn]+ SMethod_TextDocumentSignatureHelp -> ["signatureHelpOn" A..= plcSignatureHelpOn] SMethod_TextDocumentCompletion -> ["completionOn" A..= plcCompletionOn] SMethod_TextDocumentPrepareCallHierarchy -> ["callHierarchyOn" A..= plcCallHierarchyOn] SMethod_TextDocumentSemanticTokensFull -> ["semanticTokensOn" A..= plcSemanticTokensOn]+ SMethod_TextDocumentSemanticTokensFullDelta -> ["semanticTokensOn" A..= plcSemanticTokensOn] _ -> [] -- | Generates json schema used in haskell vscode extension@@ -119,12 +134,15 @@ 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@@ -135,3 +153,92 @@ ] withIdPrefix x = "haskell.plugin." <> pId <> "." <> x toKey' = fromString . T.unpack . withIdPrefix+++-- | Generates markdown tables for custom config+pluginsCustomConfigToMarkdownTables :: IdePlugins a -> T.Text+pluginsCustomConfigToMarkdownTables IdePlugins {..} = T.unlines+ $ map renderCfg+ $ filter (\(PluginCustomConfig _ params) -> not $ null params)+ $ map toPluginCustomConfig ipMap+ where+ toPluginCustomConfig :: PluginDescriptor ideState -> PluginCustomConfig+ toPluginCustomConfig PluginDescriptor {pluginConfigDescriptor = ConfigDescriptor {configCustomConfig = c}, pluginId = PluginId pId} =+ PluginCustomConfig { pcc'Name = pId, pcc'Params = toPluginCustomConfigParams c}+ toPluginCustomConfigParams :: CustomConfig -> [PluginCustomConfigParam]+ toPluginCustomConfigParams (CustomConfig p) = toPluginCustomConfigParams' p+ toPluginCustomConfigParams' :: Properties r -> [PluginCustomConfigParam]+ toPluginCustomConfigParams' EmptyProperties = []+ toPluginCustomConfigParams' (ConsProperties (keyNameProxy :: KeyNameProxy s) (k :: SPropertyKey k) (m :: MetaData t) xs) =+ toEntry (SomePropertyKeyWithMetaData k m) : toPluginCustomConfigParams' xs+ where+ toEntry :: SomePropertyKeyWithMetaData -> PluginCustomConfigParam+ toEntry (SomePropertyKeyWithMetaData SNumber MetaData {..}) =+ PluginCustomConfigParam {+ pccp'Name = T.pack $ symbolVal keyNameProxy,+ pccp'Description = description,+ pccp'Default = T.pack $ show defaultValue,+ pccp'EnumValues = []+ }+ toEntry (SomePropertyKeyWithMetaData SInteger MetaData {..}) =+ PluginCustomConfigParam {+ pccp'Name = T.pack $ symbolVal keyNameProxy,+ pccp'Description = description,+ pccp'Default = T.pack $ show defaultValue,+ pccp'EnumValues = []+ }+ toEntry (SomePropertyKeyWithMetaData SString MetaData {..}) =+ PluginCustomConfigParam {+ pccp'Name = T.pack $ symbolVal keyNameProxy,+ pccp'Description = description,+ pccp'Default = T.pack $ show defaultValue,+ pccp'EnumValues = []+ }+ toEntry (SomePropertyKeyWithMetaData SBoolean MetaData {..}) =+ PluginCustomConfigParam {+ pccp'Name = T.pack $ symbolVal keyNameProxy,+ pccp'Description = description,+ pccp'Default = T.pack $ show defaultValue,+ pccp'EnumValues = []+ }+ toEntry (SomePropertyKeyWithMetaData (SObject _) MetaData {..}) =+ PluginCustomConfigParam {+ pccp'Name = T.pack $ symbolVal keyNameProxy,+ pccp'Description = description,+ pccp'Default = "TODO: nested object", -- T.pack $ show defaultValue,+ pccp'EnumValues = []+ }+ toEntry (SomePropertyKeyWithMetaData (SArray _) MetaData {..}) =+ PluginCustomConfigParam {+ pccp'Name = T.pack $ symbolVal keyNameProxy,+ pccp'Description = description,+ pccp'Default = "TODO: Array values", -- T.pack $ show defaultValue,+ pccp'EnumValues = []+ }+ toEntry (SomePropertyKeyWithMetaData (SEnum _) EnumMetaData {..}) =+ PluginCustomConfigParam {+ pccp'Name = T.pack $ symbolVal keyNameProxy,+ pccp'Description = description,+ pccp'Default = T.pack $ show defaultValue,+ pccp'EnumValues = map (T.pack . show) enumValues+ }+ toEntry (SomePropertyKeyWithMetaData SProperties PropertiesMetaData {..}) =+ PluginCustomConfigParam {+ pccp'Name = T.pack $ symbolVal keyNameProxy,+ pccp'Description = description,+ pccp'Default = T.pack $ show defaultValue,+ pccp'EnumValues = []+ }+ renderCfg :: PluginCustomConfig -> T.Text+ renderCfg (PluginCustomConfig pId pccParams) =+ T.unlines (pluginHeader : tableHeader : rows pccParams)+ where+ pluginHeader = "## " <> pId+ tableHeader =+ "| Property | Description | Default | Allowed values |" <> "\n" <>+ "| --- | --- | --- | --- |"+ rows = map renderRow+ renderRow PluginCustomConfigParam {..} =+ "| `" <> pccp'Name <> "` | " <> pccp'Description <> " | `" <> pccp'Default <> "` | " <> renderEnum pccp'EnumValues <> " |"+ renderEnum [] = " " -- Placeholder to prevent missing cells+ renderEnum vs = "<ul> " <> (T.intercalate " " $ map (\x -> "<li><code>" <> x <> "</code></li>") vs) <> " </ul>"
src/Ide/Plugin/Error.hs view
@@ -1,6 +1,5 @@-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-} module Ide.Plugin.Error ( -- * Plugin Error Handling API PluginError(..),
src/Ide/Plugin/Properties.hs view
@@ -6,21 +6,27 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} + module Ide.Plugin.Properties ( PropertyType (..), ToHsType,+ NotElem, MetaData (..), PropertyKey (..), SPropertyKey (..),+ SomePropertyKeyWithMetaData (..), KeyNameProxy (..),- Properties,+ KeyNamePath (..),+ Properties(..), HasProperty,+ HasPropertyByPath, emptyProperties, defineNumberProperty, defineIntegerProperty,@@ -29,14 +35,20 @@ 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)@@ -48,6 +60,7 @@ import GHC.OverloadedLabels (IsLabel (..)) import GHC.TypeLits + -- | Types properties may have data PropertyType = TNumber@@ -57,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@@ -66,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 } ->@@ -85,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 @@ -98,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@@ -106,7 +131,7 @@ 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'.@@ -121,12 +146,53 @@ 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@@ -145,10 +211,13 @@ 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, FindPropertyMeta s r t)+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)+ 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@@ -224,6 +293,7 @@ A.Object -> Either String (ToHsType t) parseProperty kn k x = case k of+ (SProperties, _) -> parseEither (SNumber, _) -> parseEither (SInteger, _) -> parseEither (SString, _) -> parseEither@@ -343,6 +413,16 @@ 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'@@ -368,60 +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 ps = case ps of+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 ->- fromString (T.unpack prefix <> symbolVal keyNameProxy) A..= toEntry (SomePropertyKeyWithMetaData k m) : toVSCodeExtensionSchema prefix 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,@@ -429,3 +517,17 @@ "default" A..= defaultValue, "scope" A..= A.String "resource" ]+ (SomePropertyKeyWithMetaData SProperties PropertiesMetaData {..}) ->+ map (first Just) $ toVSCodeExtensionSchema' childrenProperties++data PluginCustomConfig = PluginCustomConfig {+ pcc'Name :: T.Text,+ pcc'Params :: [PluginCustomConfigParam]+}+data PluginCustomConfigParam = PluginCustomConfigParam {+ pccp'Name :: T.Text,+ pccp'Description :: T.Text,+ pccp'Default :: T.Text,+ pccp'EnumValues :: [T.Text]+}+
src/Ide/Plugin/RangeMap.hs view
@@ -1,9 +1,5 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DerivingStrategies #-} -- | A map that allows fast \"in-range\" filtering. 'RangeMap' is meant -- to be constructed once and cached as part of a Shake rule. If@@ -17,18 +13,24 @@ fromList, fromList', filterByRange,+ elementsInRange, ) where -import Data.Bifunctor (first)-import Data.Foldable (foldl') import Development.IDE.Graph.Classes (NFData)-import Language.LSP.Protocol.Types (Position,- Range (Range),- isSubrangeOf)+ #ifdef USE_FINGERTREE+import Data.Bifunctor (first) import qualified HaskellWorks.Data.IntervalMap.FingerTree as IM+import Language.LSP.Protocol.Types (Position,+ Range (Range))+#else+import Language.LSP.Protocol.Types (Range, isSubrangeOf) #endif +#if USE_FINGERTREE && !MIN_VERSION_base(4,20,0)+import Data.List (foldl')+#endif+ -- | A map from code ranges to values. #ifdef USE_FINGERTREE newtype RangeMap a = RangeMap@@ -64,6 +66,14 @@ filterByRange range = map snd . IM.dominators (rangeToInterval range) . unRangeMap #else filterByRange range = map snd . filter (isSubrangeOf range . fst) . unRangeMap+#endif++-- | Extracts all elements from a 'RangeMap' that fall within a given 'Range'.+elementsInRange :: Range -> RangeMap a -> [a]+#ifdef USE_FINGERTREE+elementsInRange range = map snd . IM.intersections (rangeToInterval range) . unRangeMap+#else+elementsInRange range = map snd . filter (flip isSubrangeOf range . fst) . unRangeMap #endif #ifdef USE_FINGERTREE
src/Ide/Plugin/Resolve.hs view
@@ -1,11 +1,6 @@-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-} {-| This module currently includes helper functions to provide fallback support to code actions that use resolve in HLS. The difference between the two functions for code actions that don't support resolve is that@@ -26,11 +21,10 @@ (^?)) import Control.Monad.Error.Class (MonadError (throwError)) import Control.Monad.Trans.Class (lift)-import Control.Monad.Trans.Except (ExceptT (..), runExceptT)+import Control.Monad.Trans.Except (ExceptT (..)) import qualified Data.Aeson as A import Data.Maybe (catMaybes)-import Data.Row ((.!)) import qualified Data.Text as T import GHC.Generics (Generic) import Ide.Logger@@ -39,15 +33,10 @@ import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types-import Language.LSP.Server (LspT,- ProgressCancellable (Cancellable),- getClientCapabilities,- sendRequest,- withIndefiniteProgress) data Log = DoesNotSupportResolve T.Text- | ApplyWorkspaceEditFailed ResponseError+ | forall m . A.ToJSON (ErrorData m) => ApplyWorkspaceEditFailed (TResponseError m) instance Pretty Log where pretty = \case DoesNotSupportResolve fallback->@@ -69,7 +58,7 @@ mkCodeActionHandlerWithResolve recorder codeActionMethod codeResolveMethod = let newCodeActionMethod ideState pid params = do codeActionReturn <- codeActionMethod ideState pid params- caps <- lift getClientCapabilities+ caps <- lift pluginGetClientCapabilities case codeActionReturn of r@(InR Null) -> pure r (InL ls) | -- We don't need to do anything if the client supports@@ -83,7 +72,7 @@ <> mkResolveHandler SMethod_CodeActionResolve codeResolveMethod) where dropData :: CodeAction -> CodeAction dropData ca = ca & L.data_ .~ Nothing- resolveCodeAction :: Uri -> ideState -> PluginId -> (Command |? CodeAction) -> ExceptT PluginError (LspT Config IO) (Command |? CodeAction)+ resolveCodeAction :: Uri -> ideState -> PluginId -> (Command |? CodeAction) -> ExceptT PluginError (HandlerM Config) (Command |? CodeAction) resolveCodeAction _uri _ideState _plId c@(InL _) = pure c resolveCodeAction uri ideState pid (InR codeAction@CodeAction{_data_=Just value}) = do case A.fromJSON value of@@ -114,7 +103,7 @@ mkCodeActionWithResolveAndCommand recorder plId codeActionMethod codeResolveMethod = let newCodeActionMethod ideState pid params = do codeActionReturn <- codeActionMethod ideState pid params- caps <- lift getClientCapabilities+ caps <- lift pluginGetClientCapabilities case codeActionReturn of r@(InR Null) -> pure r (InL ls) | -- We don't need to do anything if the client supports@@ -144,25 +133,24 @@ codeAction & L.data_ .~ (A.toJSON .WithURI uri <$> data_) where data_ = codeAction ^? L.data_ . _Just executeResolveCmd :: ResolveFunction ideState a 'Method_CodeActionResolve -> CommandFunction ideState CodeAction- executeResolveCmd resolveProvider ideState ca@CodeAction{_data_=Just value} = do- ExceptT $ withIndefiniteProgress "Applying edits for code action..." Cancellable $ runExceptT $ do- case A.fromJSON value of- A.Error err -> throwError $ parseError (Just value) (T.pack err)- A.Success (WithURI uri innerValue) -> do- case A.fromJSON innerValue of- A.Error err -> throwError $ parseError (Just value) (T.pack err)- A.Success innerValueDecoded -> do- resolveResult <- resolveProvider ideState plId ca uri innerValueDecoded- case resolveResult of- ca2@CodeAction {_edit = Just wedits } | diffCodeActions ca ca2 == ["edit"] -> do- _ <- ExceptT $ Right <$> sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedits) handleWEditCallback- pure $ InR Null- ca2@CodeAction {_edit = Just _ } ->- throwError $ internalError $- "The resolve provider unexpectedly returned a code action with the following differing fields: "- <> (T.pack $ show $ diffCodeActions ca ca2)- _ -> throwError $ internalError "The resolve provider unexpectedly returned a result with no data field"- executeResolveCmd _ _ CodeAction{_data_= value} = throwError $ invalidParamsError ("The code action to resolve has an illegal data field: " <> (T.pack $ show value))+ executeResolveCmd resolveProvider ideState _token ca@CodeAction{_data_=Just value} = do+ case A.fromJSON value of+ A.Error err -> throwError $ parseError (Just value) (T.pack err)+ A.Success (WithURI uri innerValue) -> do+ case A.fromJSON innerValue of+ A.Error err -> throwError $ parseError (Just value) (T.pack err)+ A.Success innerValueDecoded -> do+ resolveResult <- resolveProvider ideState plId ca uri innerValueDecoded+ case resolveResult of+ ca2@CodeAction {_edit = Just wedits } | diffCodeActions ca ca2 == ["edit"] -> do+ _ <- ExceptT $ Right <$> pluginSendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedits) handleWEditCallback+ pure $ InR Null+ ca2@CodeAction {_edit = Just _ } ->+ throwError $ internalError $+ "The resolve provider unexpectedly returned a code action with the following differing fields: "+ <> (T.pack $ show $ diffCodeActions ca ca2)+ _ -> throwError $ internalError "The resolve provider unexpectedly returned a result with no data field"+ executeResolveCmd _ _ _ CodeAction{_data_= value} = throwError $ invalidParamsError ("The code action to resolve has an illegal data field: " <> (T.pack $ show value)) handleWEditCallback (Left err ) = do logWith recorder Warning (ApplyWorkspaceEditFailed err) pure ()@@ -198,7 +186,7 @@ supportsCodeActionResolve caps = caps ^? L.textDocument . _Just . L.codeAction . _Just . L.dataSupport . _Just == Just True && case caps ^? L.textDocument . _Just . L.codeAction . _Just . L.resolveSupport . _Just of- Just row -> "edit" `elem` row .! #properties+ Just ClientCodeActionResolveOptions{_properties} -> "edit" `elem` _properties _ -> False internalError :: T.Text -> PluginError@@ -211,6 +199,7 @@ parseError value errMsg = PluginInternalError ("Ide.Plugin.Resolve: Error parsing value:"<> (T.pack $ show value) <> " Error: "<> errMsg) {- Note [Code action resolve fallback to commands]+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ To make supporting code action resolve easy for plugins, we want to let them provide one implementation that can be used both when clients support resolve, and when they don't.
src/Ide/PluginUtils.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} @@ -30,10 +28,13 @@ allLspCmdIds', installSigUsr1Handler, subRange,+ rangesOverlap, positionInRange, usePropertyLsp, -- * Escape unescape,+ -- * toAbsolute+ toAbsolute ) where @@ -52,6 +53,7 @@ import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Types import Language.LSP.Server+import System.FilePath ((</>)) import qualified Text.Megaparsec as P import qualified Text.Megaparsec.Char as P import qualified Text.Megaparsec.Char.Lexer as P@@ -276,6 +278,21 @@ subRange :: Range -> Range -> Bool subRange = isSubrangeOf ++-- | Check whether the two 'Range's overlap in any way.+--+-- >>> rangesOverlap (mkRange 1 0 1 4) (mkRange 1 2 1 5)+-- True+-- >>> rangesOverlap (mkRange 1 2 1 5) (mkRange 1 0 1 4)+-- True+-- >>> rangesOverlap (mkRange 1 0 1 6) (mkRange 1 2 1 4)+-- True+-- >>> rangesOverlap (mkRange 1 2 1 4) (mkRange 1 0 1 6)+-- True+rangesOverlap :: Range -> Range -> Bool+rangesOverlap r1 r2 =+ r1 ^. L.start <= r2 ^. L.end && r2 ^. L.start <= r1 ^. L.end+ -- --------------------------------------------------------------------- allLspCmdIds' :: T.Text -> IdePlugins ideState -> [T.Text]@@ -318,3 +335,12 @@ inside' = concatMap f inside pure $ "\"" <> inside' <> "\""++-- ---------------------------------------------------------------------++-- | toAbsolute+-- use `toAbsolute` to state our intention that we are actually make a path absolute+-- the first argument should be the root directory+-- the second argument should be the relative path+toAbsolute :: FilePath -> FilePath -> FilePath+toAbsolute = (</>)
src/Ide/Types.hs view
@@ -1,27 +1,18 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE BlockArguments #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MonadComprehensions #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE CUSKs #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MonadComprehensions #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-} module Ide.Types ( PluginDescriptor(..), defaultPluginDescriptor, defaultCabalPluginDescriptor , defaultPluginPriority@@ -31,15 +22,16 @@ , IdeNotification(..) , IdePlugins(IdePlugins, ipMap) , DynFlagsModifications(..)-, Config(..), PluginConfig(..), CheckParents(..)+, Config(..), PluginConfig(..), CheckParents(..), SessionLoadingPreferenceConfig(..) , ConfigDescriptor(..), defaultConfigDescriptor, configForPlugin , CustomConfig(..), mkCustomConfig , FallbackCodeActionParams(..)-, FormattingType(..), FormattingMethod, FormattingHandler, mkFormattingHandlers+, FormattingType(..), FormattingMethod, FormattingHandler , HasTracing(..) , PluginCommand(..), CommandId(..), CommandFunction, mkLspCommand, mkLspCmdId , PluginId(..) , PluginHandler(..), mkPluginHandler+, HandlerM, runHandlerM, pluginGetClientCapabilities, pluginSendNotification, pluginSendRequest, pluginWithIndefiniteProgress , PluginHandlers(..) , PluginMethod(..) , PluginMethodHandler@@ -47,6 +39,7 @@ , PluginNotificationHandlers(..) , PluginRequestMethod(..) , getProcessID, getPid+, getVirtualFileFromVFS , installSigUsr1Handler , lookupCommandProvider , ResolveFunction@@ -71,14 +64,14 @@ (^?)) import Control.Monad (void) import Control.Monad.Error.Class (MonadError (throwError))-import Control.Monad.Trans.Class (MonadTrans (lift))+import Control.Monad.IO.Class (MonadIO) import Control.Monad.Trans.Except (ExceptT, runExceptT) import Data.Aeson hiding (Null, defaultOptions)+import qualified Data.Aeson.Types as A import Data.Default import Data.Dependent.Map (DMap) import qualified Data.Dependent.Map as DMap import qualified Data.DList as DList-import Data.Foldable (foldl') import Data.GADT.Compare import Data.Hashable (Hashable) import Data.HashMap.Strict (HashMap)@@ -102,15 +95,21 @@ import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types-import Language.LSP.Server (LspM, LspT, getVirtualFile)+import qualified Language.LSP.Protocol.Types as J+import Language.LSP.Server import Language.LSP.VFS import Numeric.Natural import OpenTelemetry.Eventlog import Options.Applicative (ParserInfo) import Prettyprinter as PP-import System.FilePath 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_@@ -179,6 +178,7 @@ , formattingProvider :: !T.Text , cabalFormattingProvider :: !T.Text , maxCompletions :: !Int+ , sessionLoading :: !SessionLoadingPreferenceConfig , plugins :: !(Map.Map PluginId PluginConfig) } deriving (Show,Eq) @@ -187,7 +187,9 @@ object [ "checkParents" .= checkParents , "checkProject" .= checkProject , "formattingProvider" .= formattingProvider+ , "cabalFormattingProvider" .= cabalFormattingProvider , "maxCompletions" .= maxCompletions+ , "sessionLoading" .= sessionLoading , "plugin" .= Map.mapKeysMonotonic (\(PluginId p) -> p) plugins ] @@ -196,11 +198,12 @@ { checkParents = CheckOnSave , checkProject = True , formattingProvider = "ormolu"- -- , formattingProvider = "floskell" -- , formattingProvider = "stylish-haskell"- , cabalFormattingProvider = "cabal-fmt"+ , cabalFormattingProvider = "cabal-gild"+ -- , cabalFormattingProvider = "cabal-fmt" -- this string value needs to kept in sync with the value provided in HlsPlugins , maxCompletions = 40+ , sessionLoading = PreferSingleComponentLoading , plugins = mempty } @@ -213,6 +216,39 @@ deriving stock (Eq, Ord, Show, Generic) deriving anyclass (FromJSON, ToJSON) ++data SessionLoadingPreferenceConfig+ = PreferSingleComponentLoading+ -- ^ Always load only a singleComponent when a new component+ -- is discovered.+ | PreferMultiComponentLoading+ -- ^ Always prefer loading multiple components in the cradle+ -- at once. This might not be always possible, if the tool doesn't+ -- support multiple components loading.+ --+ -- The cradle can decide how to handle these situations, and whether+ -- to honour the preference at all.+ deriving stock (Eq, Ord, Show, Generic)++instance Pretty SessionLoadingPreferenceConfig where+ pretty PreferSingleComponentLoading = "Prefer Single Component Loading"+ pretty PreferMultiComponentLoading = "Prefer Multiple Components Loading"++instance ToJSON SessionLoadingPreferenceConfig where+ toJSON PreferSingleComponentLoading =+ String "singleComponent"+ toJSON PreferMultiComponentLoading =+ String "multipleComponents"++instance FromJSON SessionLoadingPreferenceConfig where+ parseJSON (String val) = case val of+ "singleComponent" -> pure PreferSingleComponentLoading+ "multipleComponents" -> pure PreferMultiComponentLoading+ _ -> A.prependFailure "parsing SessionLoadingPreferenceConfig failed, "+ (A.parseFail $ "Expected one of \"singleComponent\" or \"multipleComponents\" but got " <> T.unpack val )+ parseJSON o = A.prependFailure "parsing SessionLoadingPreferenceConfig failed, "+ (A.typeMismatch "String" o)+ -- | A PluginConfig is a generic configuration for a given HLS plugin. It -- provides a "big switch" to turn it on or off as a whole, as well as small -- switches per feature, and a slot for custom config.@@ -223,9 +259,11 @@ , plcCallHierarchyOn :: !Bool , plcCodeActionsOn :: !Bool , plcCodeLensOn :: !Bool+ , plcInlayHintsOn :: !Bool , plcDiagnosticsOn :: !Bool , plcHoverOn :: !Bool , plcSymbolsOn :: !Bool+ , plcSignatureHelpOn :: !Bool , plcCompletionOn :: !Bool , plcRenameOn :: !Bool , plcSelectionRangeOn :: !Bool@@ -240,9 +278,11 @@ , plcCallHierarchyOn = True , plcCodeActionsOn = True , plcCodeLensOn = True+ , plcInlayHintsOn = True , plcDiagnosticsOn = True , plcHoverOn = True , plcSymbolsOn = True+ , plcSignatureHelpOn = True , plcCompletionOn = True , plcRenameOn = True , plcSelectionRangeOn = True@@ -252,15 +292,17 @@ } instance ToJSON PluginConfig where- toJSON (PluginConfig g ch ca cl d h s c rn sr fr st cfg) = r+ toJSON (PluginConfig g ch ca ih cl d h s sh c rn sr fr st cfg) = r where r = object [ "globalOn" .= g , "callHierarchyOn" .= ch , "codeActionsOn" .= ca , "codeLensOn" .= cl+ , "inlayHintsOn" .= ih , "diagnosticsOn" .= d , "hoverOn" .= h , "symbolsOn" .= s+ , "signatureHelpOn" .= sh , "completionOn" .= c , "renameOn" .= rn , "selectionRangeOn" .= sr@@ -284,7 +326,7 @@ , pluginNotificationHandlers :: PluginNotificationHandlers ideState , pluginModifyDynflags :: DynFlagsModifications , pluginCli :: Maybe (ParserInfo (IdeCommand ideState))- , pluginFileType :: [T.Text]+ , pluginLanguageIds :: [J.LanguageKind] -- ^ File extension of the files the plugin is responsible for. -- The plugin is only allowed to handle files with these extensions. -- When writing handlers, etc. for this plugin it can be assumed that all handled files are of this type.@@ -377,14 +419,18 @@ -- 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) => m -> PluginDescriptor c -> HandleRequestResult-pluginSupportsFileType msgParams pluginDesc =- case mfp of- Just fp | T.pack (takeExtension fp) `elem` pluginFileType pluginDesc -> HandlesRequest- _ -> DoesNotHandleRequest $ DoesNotSupportFileType (maybe "(unable to determine file type)" (T.pack . takeExtension) mfp)+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- mfp = uriToFilePath uri- uri = msgParams ^. L.textDocument . L.uri+ 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@@ -413,7 +459,9 @@ -- -- But there is no use to split it up into two different methods for now. handlesRequest- :: SMethod m+ :: 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@@ -429,24 +477,24 @@ -- with the given parameters? default handlesRequest :: (L.HasTextDocument (MessageParams m) doc, L.HasUri doc Uri)- => SMethod m -> MessageParams m -> PluginDescriptor c -> Config -> HandleRequestResult- handlesRequest _ params desc conf =- pluginEnabledGlobally desc conf <> pluginSupportsFileType params desc+ => 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) -> SMethod m -> MessageParams m+ => (PluginConfig -> Bool) -> VFS -> SMethod m -> MessageParams m -> PluginDescriptor c -> Config -> HandleRequestResult-pluginEnabledWithFeature feature _ msgParams pluginDesc config =+pluginEnabledWithFeature feature vfs _ msgParams pluginDesc config = pluginEnabledGlobally pluginDesc config <> pluginFeatureEnabled feature pluginDesc config- <> pluginSupportsFileType msgParams pluginDesc+ <> 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) -> p -> s -> PluginDescriptor c -> Config -> HandleRequestResult-pluginEnabledResolve feature _ msgParams pluginDesc config =+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@@ -459,21 +507,30 @@ handlesRequest = pluginEnabledResolve plcCodeActionsOn instance PluginMethod Request Method_TextDocumentDefinition where- handlesRequest _ msgParams pluginDesc _ = pluginSupportsFileType msgParams pluginDesc+ handlesRequest vfs _ msgParams pluginDesc _ = pluginSupportsFileType vfs msgParams pluginDesc instance PluginMethod Request Method_TextDocumentTypeDefinition where- handlesRequest _ msgParams pluginDesc _ = pluginSupportsFileType msgParams pluginDesc+ 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 _ msgParams pluginDesc _ = pluginSupportsFileType msgParams pluginDesc+ handlesRequest vfs _ msgParams pluginDesc _ = pluginSupportsFileType vfs msgParams pluginDesc instance PluginMethod Request Method_TextDocumentReferences where- handlesRequest _ msgParams pluginDesc _ = pluginSupportsFileType msgParams pluginDesc+ handlesRequest vfs _ msgParams pluginDesc _ = pluginSupportsFileType vfs msgParams pluginDesc instance PluginMethod Request Method_WorkspaceSymbol where -- Unconditionally enabled, but should it really be?- handlesRequest _ _ _ _ = HandlesRequest+ 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 @@ -484,12 +541,18 @@ 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@@ -498,28 +561,31 @@ handlesRequest = pluginEnabledWithFeature plcCompletionOn instance PluginMethod Request Method_TextDocumentFormatting where- handlesRequest _ msgParams pluginDesc conf =+ handlesRequest vfs _ msgParams pluginDesc conf = (if PluginId (formattingProvider conf) == pid || PluginId (cabalFormattingProvider conf) == pid then HandlesRequest else DoesNotHandleRequest (NotFormattingProvider (formattingProvider conf)) )- <> pluginSupportsFileType msgParams pluginDesc+ <> pluginSupportsFileType vfs msgParams pluginDesc where pid = pluginId pluginDesc instance PluginMethod Request Method_TextDocumentRangeFormatting where- handlesRequest _ msgParams pluginDesc conf =+ handlesRequest vfs _ msgParams pluginDesc conf = (if PluginId (formattingProvider conf) == pid || PluginId (cabalFormattingProvider conf) == pid then HandlesRequest else DoesNotHandleRequest (NotFormattingProvider (formattingProvider conf)))- <> pluginSupportsFileType msgParams pluginDesc+ <> 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 @@ -531,21 +597,21 @@ instance PluginMethod Request Method_CallHierarchyIncomingCalls where -- This method has no URI parameter, thus no call to 'pluginResponsible'- handlesRequest _ _ pluginDesc conf =+ 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 =+ handlesRequest _ _ _ pluginDesc conf = pluginEnabledGlobally pluginDesc conf <> pluginFeatureEnabled plcCallHierarchyOn pluginDesc conf instance PluginMethod Request Method_WorkspaceExecuteCommand where- handlesRequest _ _ _ _= HandlesRequest+ handlesRequest _ _ _ _ _ = HandlesRequest instance PluginMethod Request (Method_CustomMethod m) where- handlesRequest _ _ _ _ = HandlesRequest+ handlesRequest _ _ _ _ _ = HandlesRequest -- Plugin Notifications @@ -559,19 +625,19 @@ instance PluginMethod Notification Method_WorkspaceDidChangeWatchedFiles where -- This method has no URI parameter, thus no call to 'pluginResponsible'.- handlesRequest _ _ desc conf = pluginEnabledGlobally desc conf+ 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+ 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+ 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+ handlesRequest _ _ _ desc conf = pluginEnabledGlobally desc conf -- ---------------------------------------------------------------------@@ -605,7 +671,7 @@ --- instance PluginRequestMethod Method_TextDocumentCodeAction where combineResponses _method _config (ClientCapabilities _ textDocCaps _ _ _ _) (CodeActionParams _ _ _ _ context) resps =- InL $ fmap compat $ filter wasRequested $ concat $ mapMaybe nullToMaybe $ toList resps+ InL $ fmap compat $ concatMap (filter wasRequested) $ mapMaybe nullToMaybe $ toList resps where compat :: (Command |? CodeAction) -> (Command |? CodeAction) compat x@(InL _) = x@@ -645,6 +711,11 @@ | 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@@ -663,8 +734,12 @@ instance PluginRequestMethod Method_TextDocumentRename where +instance PluginRequestMethod Method_TextDocumentPrepareRename where+ -- TODO more intelligent combining?+ combineResponses _ _ _ _ (x :| _) = x+ instance PluginRequestMethod Method_TextDocumentHover where- combineResponses _ _ _ _ (mapMaybe nullToMaybe . toList -> hs :: [Hover]) =+ combineResponses _ _ _ _ (mapMaybe nullToMaybe . toList -> (hs :: [Hover])) = if null hs then InR Null else InL $ Hover (InL mcontent) r@@ -701,6 +776,9 @@ si = SymbolInformation name' (ds ^. L.kind) Nothing parent (ds ^. L.deprecated) loc in [si] <> children' +instance PluginRequestMethod Method_TextDocumentSignatureHelp where+ combineResponses _ _ _ _ (x :| _) = x+ instance PluginRequestMethod Method_CompletionItemResolve where -- A resolve request should only have one response. -- See Note [Resolve in PluginHandlers]@@ -760,6 +838,12 @@ 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]) @@ -847,9 +931,43 @@ instance GCompare IdeNotification where gcompare (IdeNotification a) (IdeNotification b) = gcompare a b +-- | Restricted version of 'LspM' specific to plugins.+--+-- We use this monad for running plugins instead of 'LspM', since there are+-- parts of the LSP server state which plugins should not access directly, but+-- instead only via the build system.+newtype HandlerM config a = HandlerM { _runHandlerM :: LspM config a }+ deriving newtype (Applicative, Functor, Monad, MonadIO, MonadUnliftIO)++runHandlerM :: HandlerM config a -> LspM config a+runHandlerM = _runHandlerM++-- | Wrapper of 'getClientCapabilities' for HandlerM+pluginGetClientCapabilities :: HandlerM config ClientCapabilities+pluginGetClientCapabilities = HandlerM getClientCapabilities++-- | Wrapper of 'sendNotification for HandlerM+--+-- TODO: Return notification in result instead of calling `sendNotification` directly+pluginSendNotification :: forall (m :: Method ServerToClient Notification) config. SServerMethod m -> MessageParams m -> HandlerM config ()+pluginSendNotification smethod params = HandlerM $ sendNotification smethod params++-- | Wrapper of 'sendRequest' for HandlerM+--+-- TODO: Return request in result instead of calling `sendRequest` directly+pluginSendRequest :: forall (m :: Method ServerToClient Request) config. SServerMethod m -> MessageParams m -> (Either (TResponseError m) (MessageResult m) -> HandlerM config ()) -> HandlerM config (LspId m)+pluginSendRequest smethod params action = HandlerM $ sendRequest smethod params (runHandlerM . action)++-- | Wrapper of 'withIndefiniteProgress' for HandlerM+pluginWithIndefiniteProgress :: T.Text -> Maybe ProgressToken -> ProgressCancellable -> ((T.Text -> HandlerM config ()) -> HandlerM config a) -> HandlerM config a+pluginWithIndefiniteProgress title progressToken cancellable updateAction =+ HandlerM $+ withIndefiniteProgress title progressToken cancellable $ \putUpdate ->+ runHandlerM $ updateAction (HandlerM . putUpdate)+ -- | Combine handlers for the newtype PluginHandler a (m :: Method ClientToServer Request)- = PluginHandler (PluginId -> a -> MessageParams m -> LspM Config (NonEmpty (Either PluginError (MessageResult m))))+ = PluginHandler (PluginId -> a -> MessageParams m -> HandlerM Config (NonEmpty (Either PluginError (MessageResult m)))) newtype PluginNotificationHandler a (m :: Method ClientToServer Notification) = PluginNotificationHandler (PluginId -> a -> VFS -> MessageParams m -> LspM Config ())@@ -874,7 +992,7 @@ instance Monoid (PluginNotificationHandlers a) where mempty = PluginNotificationHandlers mempty -type PluginMethodHandler a m = a -> PluginId -> MessageParams m -> ExceptT PluginError (LspM Config) (MessageResult m)+type PluginMethodHandler a m = a -> PluginId -> MessageParams m -> ExceptT PluginError (HandlerM Config) (MessageResult m) type PluginNotificationMethodHandler a m = a -> VFS -> PluginId -> MessageParams m -> LspM Config () @@ -887,7 +1005,7 @@ -> PluginHandlers ideState mkPluginHandler m f = PluginHandlers $ DMap.singleton (IdeMethod m) (PluginHandler (f' m)) where- f' :: SMethod m -> PluginId -> ideState -> MessageParams m -> LspT Config IO (NonEmpty (Either PluginError (MessageResult m)))+ f' :: SMethod m -> PluginId -> ideState -> MessageParams m -> HandlerM Config (NonEmpty (Either PluginError (MessageResult m))) -- We need to have separate functions for each method that supports resolve, so far we only support CodeActions -- CodeLens, and Completion methods. f' SMethod_TextDocumentCodeAction pid ide params@CodeActionParams{_textDocument=TextDocumentIdentifier {_uri}} =@@ -951,7 +1069,7 @@ mempty mempty Nothing- [".hs", ".lhs", ".hs-boot"]+ [J.LanguageKind_Haskell, J.LanguageKind_Custom "literate haskell"] -- | Set up a plugin descriptor, initialized with default values. -- This plugin descriptor is prepared for @.cabal@ files and as such,@@ -972,7 +1090,7 @@ mempty mempty Nothing- [".cabal"]+ [J.LanguageKind_Custom "cabal"] newtype CommandId = CommandId T.Text deriving (Show, Read, Eq, Ord)@@ -989,8 +1107,9 @@ type CommandFunction ideState a = ideState+ -> Maybe ProgressToken -> a- -> ExceptT PluginError (LspM Config) (Value |? Null)+ -> ExceptT PluginError (HandlerM Config) (Value |? Null) -- --------------------------------------------------------------------- @@ -1000,7 +1119,7 @@ -> MessageParams m -> Uri -> a- -> ExceptT PluginError (LspM Config) (MessageResult m)+ -> ExceptT PluginError (HandlerM Config) (MessageResult m) -- | Make a handler for resolve methods. In here we take your provided ResolveFunction -- and turn it into a PluginHandlers. See Note [Resolve in PluginHandlers]@@ -1077,37 +1196,15 @@ type FormattingHandler a = a+ -> Maybe ProgressToken -> FormattingType -> T.Text -> NormalizedFilePath -> FormattingOptions- -> ExceptT PluginError (LspM Config) ([TextEdit] |? Null)--mkFormattingHandlers :: forall a. FormattingHandler a -> PluginHandlers a-mkFormattingHandlers f = mkPluginHandler SMethod_TextDocumentFormatting ( provider SMethod_TextDocumentFormatting)- <> mkPluginHandler SMethod_TextDocumentRangeFormatting (provider SMethod_TextDocumentRangeFormatting)- where- provider :: forall m. FormattingMethod m => SMethod m -> PluginMethodHandler a m- provider m ide _pid params- | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = do- mf <- lift $ getVirtualFile $ toNormalizedUri uri- case mf of- Just vf -> do- let typ = case m of- SMethod_TextDocumentFormatting -> FormatText- SMethod_TextDocumentRangeFormatting -> FormatRange (params ^. L.range)- _ -> Prelude.error "mkFormattingHandlers: impossible"- f ide typ (virtualFileText vf) nfp opts- Nothing -> throwError $ PluginInvalidParams $ T.pack $ "Formatter plugin: could not get file contents for " ++ show uri-- | otherwise = throwError $ PluginInvalidParams $ T.pack $ "Formatter plugin: uriToFilePath failed for: " ++ show uri- where- uri = params ^. L.textDocument . L.uri- opts = params ^. L.options+ -> ExceptT PluginError (HandlerM Config) ([TextEdit] |? Null) -- --------------------------------------------------------------------- - data FallbackCodeActionParams = FallbackCodeActionParams { fallbackWorkspaceEdit :: Maybe WorkspaceEdit@@ -1169,6 +1266,20 @@ getPid :: IO T.Text getPid = T.pack . show <$> getProcessID +getVirtualFileFromVFS :: VFS -> NormalizedUri -> Maybe VirtualFile+getVirtualFileFromVFS (VFS vfs) uri =+ case Map.lookup uri vfs of+ Just (Open x) -> Just x+ Just (Closed _) -> Nothing+ Nothing -> Nothing++getVirtualFileFromVFSIncludingClosed :: VFS -> NormalizedUri -> Maybe VirtualFileEntry+getVirtualFileFromVFSIncludingClosed (VFS vfs) uri =+ case Map.lookup uri vfs of+ Just x -> Just x+ Nothing -> Nothing++ getProcessID :: IO Int installSigUsr1Handler :: IO () -> IO () @@ -1183,6 +1294,7 @@ #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
test/Ide/PluginUtilsTest.hs view
@@ -1,19 +1,30 @@+{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -Wno-orphans #-} module Ide.PluginUtilsTest ( tests ) where -import Data.Char (isPrint)+import qualified Data.Aeson as A+import qualified Data.Aeson.Types as A+import Data.ByteString.Lazy (ByteString)+import Data.Function ((&)) import qualified Data.Set as Set import qualified Data.Text as T+import Ide.Plugin.Properties (KeyNamePath (..),+ definePropertiesProperty,+ defineStringProperty,+ emptyProperties, toDefaultJSON,+ toVSCodeExtensionSchema,+ usePropertyByPath,+ usePropertyByPathEither) import qualified Ide.Plugin.RangeMap as RangeMap-import Ide.PluginUtils (extractTextInRange,- positionInRange, unescape)+import Ide.PluginUtils (extractTextInRange, unescape) import Language.LSP.Protocol.Types (Position (..), Range (Range), UInt, isSubrangeOf) import Test.Tasty+import Test.Tasty.Golden (goldenVsStringDiff) import Test.Tasty.HUnit import Test.Tasty.QuickCheck @@ -24,6 +35,7 @@ , localOption (QuickCheckMaxSize 10000) $ testProperty "RangeMap-List filtering identical" $ prop_rangemapListEq @Int+ , propertyTest ] unescapeTest :: TestTree@@ -106,7 +118,7 @@ pure $ Range x1 x2 where genRangeLength :: Gen UInt- genRangeLength = fromInteger <$> chooseInteger (5, 50)+ genRangeLength = uInt (5, 50) genRangeMultiline :: Gen Range genRangeMultiline = do@@ -119,17 +131,20 @@ pure $ Range x1 x2 where genSecond :: Gen UInt- genSecond = fromInteger <$> chooseInteger (0, 10)+ genSecond = uInt (0, 10) genPosition :: Gen Position genPosition = Position- <$> (fromInteger <$> chooseInteger (0, 1000))- <*> (fromInteger <$> chooseInteger (0, 150))+ <$> uInt (0, 1000)+ <*> uInt (0, 150) +uInt :: (Integer, Integer) -> Gen UInt+uInt (a, b) = fromInteger <$> chooseInteger (a, b)+ instance Arbitrary Range where arbitrary = genRange -prop_rangemapListEq :: (Show a, Eq a, Ord a) => Range -> [(Range, a)] -> Property+prop_rangemapListEq :: (Show a, Ord a) => Range -> [(Range, a)] -> Property prop_rangemapListEq r xs = let filteredList = (map snd . filter (isSubrangeOf r . fst)) xs filteredRangeMap = RangeMap.filterByRange r (RangeMap.fromList' xs)@@ -137,3 +152,54 @@ cover 5 (length filteredList == 1) "1 match" $ cover 2 (length filteredList > 1) ">1 matches" $ Set.fromList filteredList === Set.fromList filteredRangeMap+++gitDiff :: FilePath -> FilePath -> [String]+gitDiff fRef fNew = ["git", "-c", "core.fileMode=false", "diff", "-w", "--no-index", "--text", "--exit-code", fRef, fNew]++goldenGitDiff :: TestName -> FilePath -> IO ByteString -> TestTree+goldenGitDiff name = goldenVsStringDiff name gitDiff++testDir :: FilePath+testDir = "test/testdata/Property"++propertyTest :: TestTree+propertyTest = testGroup "property api tests" [+ goldenGitDiff "property toVSCodeExtensionSchema" (testDir <> "/NestedPropertyVscode.json") (return $ A.encode $ A.object $ toVSCodeExtensionSchema "top." nestedPropertiesExample)+ , goldenGitDiff "property toDefaultJSON" (testDir <> "/NestedPropertyDefault.json") (return $ A.encode $ A.object $ toDefaultJSON nestedPropertiesExample)+ , testCase "parsePropertyPath single key path" $ do+ let obj = A.object (toDefaultJSON nestedPropertiesExample)+ let key1 = A.parseEither (A.withObject "test parsePropertyPath" $ \o -> do+ let key1 = usePropertyByPathEither examplePath1 nestedPropertiesExample o+ return key1) obj+ key1 @?= Right (Right "baz")+ , testCase "parsePropertyPath two key path" $ do+ let obj = A.object (toDefaultJSON nestedPropertiesExample)+ let key1 = A.parseEither (A.withObject "test parsePropertyPath" $ \o -> do+ let key1 = usePropertyByPathEither examplePath2 nestedPropertiesExample o+ return key1) obj+ key1 @?= Right (Right "foo")+ , testCase "parsePropertyPath two key path default" $ do+ let obj = A.object []+ let key1 = A.parseEither (A.withObject "test parsePropertyPath" $ \o -> do+ let key1 = usePropertyByPath examplePath2 nestedPropertiesExample o+ return key1) obj+ key1 @?= Right "foo"+ , testCase "parsePropertyPath two key path not default" $ do+ let obj = A.object (toDefaultJSON nestedPropertiesExample2)+ let key1 = A.parseEither (A.withObject "test parsePropertyPath" $ \o -> do+ let key1 = usePropertyByPathEither examplePath2 nestedPropertiesExample o+ return key1) obj+ key1 @?= Right (Right "xxx")+ ]+ where+ nestedPropertiesExample = emptyProperties+ & definePropertiesProperty #parent "parent" (emptyProperties & defineStringProperty #foo "foo" "foo" & defineStringProperty #boo "boo" "boo")+ & defineStringProperty #baz "baz" "baz"++ nestedPropertiesExample2 = emptyProperties+ & definePropertiesProperty #parent "parent" (emptyProperties & defineStringProperty #foo "foo" "xxx")+ & defineStringProperty #baz "baz" "baz"++ examplePath1 = SingleKey #baz+ examplePath2 = ConsKeysPath #parent (SingleKey #foo)
test/Ide/TypesTests.hs view
@@ -1,23 +1,19 @@-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE TypeFamilies #-} module Ide.TypesTests ( tests ) where-import Control.Lens (preview, (?~), (^?))-import Control.Monad ((>=>))+import Control.Lens ((?~), (^?)) import Data.Default (Default (def)) import Data.Function ((&))-import Data.List.NonEmpty (NonEmpty ((:|)), nonEmpty)+import Data.List.NonEmpty (NonEmpty ((:|))) import Data.Maybe (isJust) import qualified Data.Text as Text-import Ide.Types (Config (Config),- PluginRequestMethod (combineResponses))+import Ide.Types (PluginRequestMethod (combineResponses)) import qualified Language.LSP.Protocol.Lens as L-import Language.LSP.Protocol.Message (Method (Method_TextDocumentDefinition),+import Language.LSP.Protocol.Message (MessageParams, MessageResult, SMethod (..)) import Language.LSP.Protocol.Types (ClientCapabilities, Definition (Definition),@@ -29,18 +25,17 @@ Null (Null), Position (Position), Range (Range),- TextDocumentClientCapabilities (TextDocumentClientCapabilities, _definition),+ TextDocumentClientCapabilities, TextDocumentIdentifier (TextDocumentIdentifier), TypeDefinitionClientCapabilities (TypeDefinitionClientCapabilities, _dynamicRegistration, _linkSupport), TypeDefinitionParams (..),- Uri (Uri), _L, _R,+ Uri (Uri), _L, _R, _definition, _typeDefinition, filePathToUri, type (|?) (..)) import Test.Tasty (TestTree, testGroup)-import Test.Tasty.HUnit (assertBool, testCase, (@=?))+import Test.Tasty.HUnit (testCase, (@=?)) import Test.Tasty.QuickCheck (ASCIIString (ASCIIString), Arbitrary (arbitrary), Gen,- NonEmptyList (NonEmpty), arbitraryBoundedEnum, cover, listOf1, oneof, testProperty, (===))@@ -63,6 +58,11 @@ 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))@@ -177,7 +177,11 @@ (isJust (result ^? _L) || isJust (result ^? _R >>= (^? _R))) === True ] -(range1, range2, range3) = (Range (Position 3 0) $ Position 3 5, Range (Position 5 7) $ Position 5 13, Range (Position 24 30) $ Position 24 40)++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