From f135edb1317574a1cbfc1fd629f5f01fd911d1e7 Mon Sep 17 00:00:00 2001 From: Potato Hatsue <1793913507@qq.com> Date: Fri, 19 Mar 2021 13:30:16 +0800 Subject: [PATCH] Regularize custom config of plugins (#1576) * Support declarative custom config, add --vscode-extension-schema * Add globalOn * Add --generate-default-config * Port tactic plugin * Fix build of tactic plugin test * Fix tactic plugin test * Revert format changes in tactics plugin * Change the descriptor of tactics plugin to "tactics" * Update plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs Co-authored-by: Sandy Maguire * Apply a bunch of @isovector's suggestions * Document Ide.Plugin.ConfigUtils * Add TInteger * Fix build Co-authored-by: Sandy Maguire Co-authored-by: mergify[bot] <37929162+mergify[bot]@users.noreply.github.com> --- exe/Plugins.hs | 2 +- ghcide/exe/Arguments.hs | 24 +- ghcide/exe/Main.hs | 15 + ghcide/ghcide.cabal | 3 +- .../src/Development/IDE/Plugin/TypeLenses.hs | 48 +- haskell-language-server.cabal | 1 + hls-plugin-api/hls-plugin-api.cabal | 2 + hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs | 127 +++++ hls-plugin-api/src/Ide/Plugin/Properties.hs | 433 ++++++++++++++++++ hls-plugin-api/src/Ide/PluginUtils.hs | 21 +- hls-plugin-api/src/Ide/Types.hs | 20 +- .../src/Wingman/LanguageServer.hs | 33 +- .../hls-tactics-plugin/src/Wingman/Plugin.hs | 16 +- .../hls-tactics-plugin/src/Wingman/Types.hs | 23 +- plugins/hls-tactics-plugin/test/Server.hs | 2 +- plugins/hls-tactics-plugin/test/Utils.hs | 7 +- src/Ide/Arguments.hs | 16 +- src/Ide/Main.hs | 56 ++- 18 files changed, 738 insertions(+), 111 deletions(-) create mode 100644 hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs create mode 100644 hls-plugin-api/src/Ide/Plugin/Properties.hs diff --git a/exe/Plugins.hs b/exe/Plugins.hs index 9fe8a1583a..dec73e8994 100644 --- a/exe/Plugins.hs +++ b/exe/Plugins.hs @@ -100,7 +100,7 @@ idePlugins includeExamples = pluginDescToIdePlugins allPlugins Fourmolu.descriptor "fourmolu" : #endif #if tactic - Tactic.descriptor "tactic" : + Tactic.descriptor "tactics" : #endif #if ormolu Ormolu.descriptor "ormolu" : diff --git a/ghcide/exe/Arguments.hs b/ghcide/exe/Arguments.hs index f78202a8f0..125cf66961 100644 --- a/ghcide/exe/Arguments.hs +++ b/ghcide/exe/Arguments.hs @@ -11,16 +11,18 @@ type Arguments = Arguments' IdeCmd data IdeCmd = Typecheck [FilePath] | DbCmd Options Command | LSP data Arguments' a = Arguments - {argLSP :: Bool - ,argsCwd :: Maybe FilePath - ,argsVersion :: Bool - ,argsShakeProfiling :: Maybe FilePath - ,argsOTMemoryProfiling :: Bool - ,argsTesting :: Bool - ,argsDisableKick :: Bool - ,argsThreads :: Int - ,argsVerbose :: Bool - ,argFilesOrCmd :: a + {argLSP :: Bool + ,argsCwd :: Maybe FilePath + ,argsVersion :: Bool + ,argsVSCodeExtensionSchema :: Bool + ,argsDefaultConfig :: Bool + ,argsShakeProfiling :: Maybe FilePath + ,argsOTMemoryProfiling :: Bool + ,argsTesting :: Bool + ,argsDisableKick :: Bool + ,argsThreads :: Int + ,argsVerbose :: Bool + ,argFilesOrCmd :: a } getArguments :: IO Arguments @@ -35,6 +37,8 @@ arguments = Arguments <$> switch (long "lsp" <> help "Start talking to an LSP client") <*> optional (strOption $ long "cwd" <> metavar "DIR" <> help "Change to this directory") <*> switch (long "version" <> help "Show ghcide and GHC versions") + <*> switch (long "vscode-extension-schema" <> help "Print generic config schema for plugins (used in the package.json of haskell vscode extension)") + <*> switch (long "generate-default-config" <> help "Print config supported by the server with default values") <*> optional (strOption $ long "shake-profiling" <> metavar "DIR" <> help "Dump profiling reports to this directory") <*> switch (long "ot-memory-profiling" <> help "Record OpenTelemetry info to the eventlog. Needs the -l RTS flag to have an effect") <*> switch (long "test" <> help "Enable additional lsp messages used by the testsuite") diff --git a/ghcide/exe/Main.hs b/ghcide/exe/Main.hs index e2b3b51512..042afed11c 100644 --- a/ghcide/exe/Main.hs +++ b/ghcide/exe/Main.hs @@ -9,11 +9,14 @@ import Arguments (Arguments' (..), IdeCmd (..), getArguments) import Control.Concurrent.Extra (newLock, withLock) import Control.Monad.Extra (unless, when, whenJust) +import qualified Data.Aeson.Encode.Pretty as A import Data.Default (Default (def)) import Data.List.Extra (upper) import Data.Maybe (fromMaybe) import qualified Data.Text as T import qualified Data.Text.IO as T +import Data.Text.Lazy.Encoding (decodeUtf8) +import qualified Data.Text.Lazy.IO as LT import Data.Version (showVersion) import Development.GitRev (gitHash) import Development.IDE (Logger (Logger), @@ -29,6 +32,8 @@ import Development.IDE.Types.Options import Development.Shake (ShakeOptions (shakeThreads)) import HieDb.Run (Options (..), runCommand) import Ide.Plugin.Config (Config (checkParents, checkProject)) +import Ide.Plugin.ConfigUtils (pluginsToDefaultConfig, + pluginsToVSCodeExtensionSchema) import Ide.PluginUtils (pluginDescToIdePlugins) import Paths_ghcide (version) import qualified System.Directory.Extra as IO @@ -58,6 +63,16 @@ main = do if argsVersion then ghcideVersion >>= putStrLn >> exitSuccess else hPutStrLn stderr {- see WARNING above -} =<< ghcideVersion + let hlsPlugins = pluginDescToIdePlugins GhcIde.descriptors + + when argsVSCodeExtensionSchema $ do + LT.putStrLn $ decodeUtf8 $ A.encodePretty $ pluginsToVSCodeExtensionSchema hlsPlugins + exitSuccess + + when argsDefaultConfig $ do + LT.putStrLn $ decodeUtf8 $ A.encodePretty $ pluginsToDefaultConfig hlsPlugins + exitSuccess + whenJust argsCwd IO.setCurrentDirectory -- lock to avoid overlapping output on stdout diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index a7de514993..50e8296126 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -284,7 +284,8 @@ executable ghcide optparse-applicative, shake, text, - unordered-containers + unordered-containers, + aeson-pretty other-modules: Arguments Paths_ghcide diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index 40bd1390bb..3088d6d221 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE TypeFamilies #-} -- | An HLS plugin to provide code lenses for type signatures module Development.IDE.Plugin.TypeLenses ( @@ -13,16 +14,12 @@ module Development.IDE.Plugin.TypeLenses ( import Avail (availsToNameSet) import Control.DeepSeq (rwhnf) -import Control.Monad (join) import Control.Monad.Extra (whenMaybe) import Control.Monad.IO.Class (MonadIO (liftIO)) -import qualified Data.Aeson as A import Data.Aeson.Types (Value (..), toJSON) -import qualified Data.Aeson.Types as A import qualified Data.HashMap.Strict as Map import Data.List (find) -import Data.Maybe (catMaybes, fromJust, - fromMaybe) +import Data.Maybe (catMaybes, fromJust) import qualified Data.Text as T import Development.IDE (GhcSession (..), HscEnvEq (hscEnv), @@ -52,16 +49,17 @@ import GhcPlugins (GlobalRdrEnv, realSrcLocSpan, tidyOpenType) import HscTypes (mkPrintUnqualified) -import Ide.Plugin.Config (Config, - PluginConfig (plcConfig)) -import Ide.PluginUtils (getPluginConfig, - mkLspCommand) +import Ide.Plugin.Config (Config) +import Ide.Plugin.Properties +import Ide.PluginUtils (mkLspCommand, + usePropertyLsp) import Ide.Types (CommandFunction, CommandId (CommandId), PluginCommand (PluginCommand), PluginDescriptor (..), PluginId, defaultPluginDescriptor, + mkCustomConfig, mkPluginHandler) import qualified Language.LSP.Server as LSP import Language.LSP.Types (ApplyWorkspaceEditParams (ApplyWorkspaceEditParams), @@ -90,15 +88,24 @@ descriptor plId = { pluginHandlers = mkPluginHandler STextDocumentCodeLens codeLensProvider , pluginCommands = [PluginCommand (CommandId typeLensCommandId) "adds a signature" commandHandler] , pluginRules = rules + , pluginCustomConfig = mkCustomConfig properties } +properties :: Properties '[ 'PropertyKey "mode" 'TEnum] +properties = emptyProperties + & defineEnumProperty #mode "Control how type lenses are shown" + [ ("always", "Always displays type lenses of global bindings") + , ("exported", "Only display type lenses of exported global bindings") + , ("diagnostics", "Follows error messages produced by GHC about missing signatures") + ] "always" + codeLensProvider :: IdeState -> PluginId -> CodeLensParams -> LSP.LspM Config (Either ResponseError (List CodeLens)) codeLensProvider ideState pId CodeLensParams{_textDocument = TextDocumentIdentifier uri} = do - (fromMaybe Always . join -> mode) <- fmap (parseCustomConfig . plcConfig) <$> getPluginConfig pId + mode <- readMode <$> usePropertyLsp #mode pId properties fmap (Right . List) $ case uriToFilePath' uri of Just (toNormalizedFilePath' -> filePath) -> liftIO $ do tmr <- runAction "codeLens.TypeCheck" ideState (use TypeCheck filePath) @@ -202,14 +209,6 @@ data Mode Diagnostics deriving (Eq, Ord, Show, Read, Enum) -instance A.FromJSON Mode where - parseJSON = A.withText "Mode" $ \s -> - case T.toLower s of - "always" -> pure Always - "exported" -> pure Exported - "diagnostics" -> pure Diagnostics - _ -> A.unexpected (A.String s) - -------------------------------------------------------------------------------- showDocRdrEnv :: DynFlags -> GlobalRdrEnv -> SDoc -> String @@ -246,8 +245,13 @@ rules = do result <- liftIO $ gblBindingType (hscEnv <$> hsc) (tmrTypechecked <$> tmr) pure ([], result) -parseCustomConfig :: A.Object -> Maybe Mode -parseCustomConfig = A.parseMaybe (A..: "mode") +readMode :: T.Text -> Mode +readMode = \case + "always" -> Always + "exported" -> Exported + "diagnostics" -> Diagnostics + -- actually it never happens because of 'usePropertyLsp' + _ -> error "failed to parse type lenses mode" gblBindingType :: Maybe HscEnv -> Maybe TcGblEnv -> IO (Maybe GlobalBindingTypeSigsResult) gblBindingType (Just hsc) (Just gblEnv) = do diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 9ffd20f0e4..40313da1fe 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -69,6 +69,7 @@ library , safe-exceptions , sqlite-simple , unordered-containers + , aeson-pretty ghc-options: -Wall -Wredundant-constraints -Wno-name-shadowing -Wno-unticked-promoted-constructors diff --git a/hls-plugin-api/hls-plugin-api.cabal b/hls-plugin-api/hls-plugin-api.cabal index 2015980309..378364c434 100644 --- a/hls-plugin-api/hls-plugin-api.cabal +++ b/hls-plugin-api/hls-plugin-api.cabal @@ -27,6 +27,8 @@ library exposed-modules: Ide.Logger Ide.Plugin.Config + Ide.Plugin.ConfigUtils + Ide.Plugin.Properties Ide.PluginUtils Ide.Types diff --git a/hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs b/hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs new file mode 100644 index 0000000000..fad0fe7ed9 --- /dev/null +++ b/hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} + +module Ide.Plugin.ConfigUtils where + +import qualified Data.Aeson as A +import qualified Data.Aeson.Types as A +import Data.Default (def) +import qualified Data.Dependent.Map as DMap +import qualified Data.Dependent.Sum as DSum +import qualified Data.HashMap.Lazy as HMap +import qualified Data.Map as Map +import Ide.Plugin.Config +import Ide.Plugin.Properties (toDefaultJSON, toVSCodeExtensionSchema) +import Ide.Types +import Language.LSP.Types + +-- Attention: +-- 'diagnosticsOn' will never be added into the default config or the schema, +-- since diagnostics emit in arbitrary shake rules -- we don't know +-- whether a plugin is capable of producing diagnostics. + +-- | Generates a defalut 'Config', but remains only effective items +pluginsToDefaultConfig :: IdePlugins a -> A.Value +pluginsToDefaultConfig IdePlugins {..} = + A.Object $ + HMap.adjust + ( \(unsafeValueToObject -> o) -> + A.Object $ HMap.insert "plugin" elems o -- inplace the "plugin" section with our 'elems', leaving others unchanged + ) + "haskell" + (unsafeValueToObject (A.toJSON defaultConfig)) + where + defaultConfig@Config {} = def + unsafeValueToObject (A.Object o) = o + unsafeValueToObject _ = error "impossible" + elems = A.object $ mconcat $ singlePlugin <$> Map.elems ipMap + -- Splice genericDefaultConfig and dedicatedDefaultConfig + -- Example: + -- + -- { + -- "plugin-id": { + -- "globalOn": true, + -- "codeActionsOn": true, + -- "codeLensOn": true, + -- "config": { + -- "property1": "foo" + -- } + -- } + -- } + singlePlugin PluginDescriptor {..} = + let x = genericDefaultConfig <> dedicatedDefaultConfig + in [pId A..= A.object x | not $ null x] + where + (PluginHandlers (DMap.toList -> handlers)) = pluginHandlers + customConfigToDedicatedDefaultConfig (CustomConfig p) = toDefaultJSON p + -- Example: + -- + -- { + -- "globalOn": true, + -- "codeActionsOn": true, + -- "codeLensOn": true + -- } + -- + -- we don't generate the config section if the plugin doesn't register any of the following six methods, + -- which avoids producing trivial configuration for formatters: + -- + -- "stylish-haskell": { + -- "globalOn": true + -- } + genericDefaultConfig = + let x = mconcat (handlersToGenericDefaultConfig <$> handlers) + in ["globalOn" A..= True | not $ null x] <> x + -- Example: + -- + -- { + -- "config": { + -- "property1": "foo" + -- } + --} + dedicatedDefaultConfig = + let x = customConfigToDedicatedDefaultConfig pluginCustomConfig + in ["config" A..= A.object x | not $ null x] + + (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] + _ -> [] + +-- | Generates json schema used in haskell vscode extension +-- Similar to 'pluginsToDefaultConfig' but simpler, since schema has a flatten structure +pluginsToVSCodeExtensionSchema :: IdePlugins a -> A.Value +pluginsToVSCodeExtensionSchema IdePlugins {..} = A.object $ mconcat $ singlePlugin <$> Map.elems ipMap + where + singlePlugin PluginDescriptor {..} = genericSchema <> dedicatedSchema + where + (PluginHandlers (DMap.toList -> handlers)) = pluginHandlers + customConfigToDedicatedSchema (CustomConfig p) = toVSCodeExtensionSchema (withIdPrefix "config.") p + (PluginId pId) = pluginId + genericSchema = withIdPrefix "globalOn" A..= schemaEntry "plugin" : mconcat (handlersToGenericSchema <$> handlers) + dedicatedSchema = customConfigToDedicatedSchema pluginCustomConfig + handlersToGenericSchema (IdeMethod m DSum.:=> _) = case m of + STextDocumentCodeAction -> [withIdPrefix "codeActionsOn" A..= schemaEntry "code actions"] + STextDocumentCodeLens -> [withIdPrefix "codeLensOn" A..= schemaEntry "code lenses"] + STextDocumentRename -> [withIdPrefix "renameOn" A..= schemaEntry "rename"] + STextDocumentHover -> [withIdPrefix "hoverOn" A..= schemaEntry "hover"] + STextDocumentDocumentSymbol -> [withIdPrefix "symbolsOn" A..= schemaEntry "symbols"] + STextDocumentCompletion -> [withIdPrefix "completionOn" A..= schemaEntry "completions"] + _ -> [] + schemaEntry desc = + A.object + [ "scope" A..= A.String "resource", + "type" A..= A.String "boolean", + "default" A..= True, + "description" A..= A.String ("Enables " <> pId <> " " <> desc) + ] + withIdPrefix x = "haskell.plugin." <> pId <> "." <> x diff --git a/hls-plugin-api/src/Ide/Plugin/Properties.hs b/hls-plugin-api/src/Ide/Plugin/Properties.hs new file mode 100644 index 0000000000..ba2edb5f49 --- /dev/null +++ b/hls-plugin-api/src/Ide/Plugin/Properties.hs @@ -0,0 +1,433 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +-- See Note [Constraints] +{-# OPTIONS_GHC -Wno-redundant-constraints #-} + +module Ide.Plugin.Properties + ( PropertyType (..), + ToHsType, + MetaData (..), + PropertyKey (..), + SPropertyKey (..), + KeyNameProxy (..), + Properties, + HasProperty, + emptyProperties, + defineNumberProperty, + defineIntegerProperty, + defineStringProperty, + defineBooleanProperty, + defineObjectProperty, + defineArrayProperty, + defineEnumProperty, + toDefaultJSON, + toVSCodeExtensionSchema, + usePropertyEither, + useProperty, + (&), + ) +where + +import qualified Data.Aeson as A +import qualified Data.Aeson.Types as A +import Data.Either (fromRight) +import Data.Function ((&)) +import Data.Kind (Constraint) +import qualified Data.Map.Strict as Map +import qualified Data.Text as T +import GHC.OverloadedLabels (IsLabel (..)) +import GHC.TypeLits +import Unsafe.Coerce (unsafeCoerce) + +-- | Types properties may have +data PropertyType + = TNumber + | TInteger + | TString + | TBoolean + | TObject + | TArray + | TEnum + +type family ToHsType (t :: PropertyType) where + ToHsType 'TNumber = Double -- in js, there are no distinct types for integers and floating-point values + ToHsType 'TInteger = Int -- so here we use Double for Number, Int for Integer + ToHsType 'TString = T.Text + ToHsType 'TBoolean = Bool + ToHsType 'TObject = A.Object + ToHsType 'TArray = A.Array + ToHsType 'TEnum = T.Text -- supports only text enum now + +-- --------------------------------------------------------------------- + +-- | Metadata of a property +data MetaData (t :: PropertyType) where + MetaData :: + (IsTEnum t ~ 'False) => + { defaultValue :: ToHsType t, + description :: T.Text + } -> + MetaData t + EnumMetaData :: + (IsTEnum t ~ 'True) => + { defaultValue :: ToHsType t, + description :: T.Text, + enumValues :: [ToHsType t], + enumDescriptions :: [T.Text] + } -> + MetaData t + +-- | Used at type level for name-type mapping in 'Properties' +data PropertyKey = PropertyKey Symbol PropertyType + +-- | Singleton type of 'PropertyKey' +data SPropertyKey (k :: PropertyKey) where + SNumber :: SPropertyKey ('PropertyKey s 'TNumber) + SInteger :: SPropertyKey ('PropertyKey s 'TInteger) + SString :: SPropertyKey ('PropertyKey s 'TString) + SBoolean :: SPropertyKey ('PropertyKey s 'TBoolean) + SObject :: SPropertyKey ('PropertyKey s 'TObject) + SArray :: SPropertyKey ('PropertyKey s 'TArray) + SEnum :: SPropertyKey ('PropertyKey s 'TEnum) + +-- | Existential wrapper of 'SPropertyKey', with an extra 'MetaData' +data SomePropertyKeyWithMetaData + = forall k s t. + (k ~ 'PropertyKey s t) => + 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. +-- A property is an immediate child of the json object in each plugin's "config" section. +-- It was designed to be compatible with vscode's settings UI. +-- Use 'emptyProperties' and 'useProperty' to create and consume 'Properties'. +newtype Properties (r :: [PropertyKey]) = Properties (Map.Map String SomePropertyKeyWithMetaData) + +-- | A proxy type in order to allow overloaded labels as properties' names at the call site +data KeyNameProxy (s :: Symbol) = KnownSymbol s => KeyNameProxy + +instance (KnownSymbol s', s ~ s') => IsLabel s (KeyNameProxy s') where + fromLabel = KeyNameProxy + +-- --------------------------------------------------------------------- + +type family IsTEnum (t :: PropertyType) :: Bool where + IsTEnum 'TEnum = 'True + IsTEnum _ = 'False + +type family FindByKeyName (s :: Symbol) (r :: [PropertyKey]) :: PropertyType where + FindByKeyName s ('PropertyKey s t ': _) = t + FindByKeyName s (_ ': xs) = FindByKeyName s xs + +type family Elem (s :: Symbol) (r :: [PropertyKey]) :: Constraint where + Elem s ('PropertyKey s _ ': _) = () + Elem s (_ ': xs) = Elem s xs + Elem s '[] = TypeError ('Text "The key ‘" ':<>: 'Text s ':<>: 'Text "’ is missing") + +type family NotElem (s :: Symbol) (r :: [PropertyKey]) :: Constraint where + NotElem s ('PropertyKey s _ ': _) = TypeError ('Text "The key ‘" ':<>: 'Text s ':<>: 'Text "’ is already defined") + 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) + +-- --------------------------------------------------------------------- + +-- | Creates a 'Properties' that defines no property +-- +-- Useful to start a definitions chain, for example: +-- @ +-- properties = +-- emptyProperties +-- & defineStringProperty +-- #exampleString +-- "Description of exampleString" +-- "Foo" +-- & defineNumberProperty +-- #exampleNumber +-- "Description of exampleNumber" +-- 233 +-- @ +emptyProperties :: Properties '[] +emptyProperties = Properties Map.empty + +insert :: + (k ~ 'PropertyKey s t, NotElem s r, KnownSymbol s) => + KeyNameProxy s -> + SPropertyKey k -> + MetaData t -> + Properties r -> + Properties (k ': r) +insert kn key metadata (Properties old) = + Properties + ( Map.insert + (symbolVal kn) + (SomePropertyKeyWithMetaData key metadata) + old + ) + +find :: + (HasProperty s k t r) => + KeyNameProxy s -> + Properties r -> + (SPropertyKey k, MetaData t) +find kn (Properties p) = case p Map.! symbolVal kn of + (SomePropertyKeyWithMetaData sing metadata) -> + -- Note [Constraints] + -- It's safe to use unsafeCoerce here: + -- Since each property name is unique that the redefinition will be prevented by predication on the type level list, + -- the value we get from the name-indexed map must be exactly the singleton and metadata corresponding to the type. + -- We drop this information at type level: some of the above type families return '() :: Constraint', + -- so GHC will consider them as redundant. + -- But we encode it using semantically identical 'Map' at term level, + -- which avoids inducting on the list by defining a new type class. + unsafeCoerce (sing, metadata) + +-- --------------------------------------------------------------------- + +-- | Given the name of a defined property, generates a JSON parser of 'plcConfig' +usePropertyEither :: + (HasProperty s k t r) => + KeyNameProxy s -> + Properties r -> + A.Object -> + Either String (ToHsType t) +usePropertyEither kn p = parseProperty kn (find kn p) + +-- | Like 'usePropertyEither' but returns 'defaultValue' on parse error +useProperty :: + (HasProperty s k t r) => + KeyNameProxy s -> + Properties r -> + Maybe A.Object -> + ToHsType t +useProperty kn p = + maybe + (defaultValue metadata) + (fromRight (defaultValue metadata) . usePropertyEither kn p) + where + (_, metadata) = find kn p + +parseProperty :: + (k ~ 'PropertyKey s t, KnownSymbol s) => + KeyNameProxy s -> + (SPropertyKey k, MetaData t) -> + A.Object -> + Either String (ToHsType t) +parseProperty kn k x = case k of + (SNumber, _) -> parseEither + (SInteger, _) -> parseEither + (SString, _) -> parseEither + (SBoolean, _) -> parseEither + (SObject, _) -> parseEither + (SArray, _) -> parseEither + (SEnum, EnumMetaData {..}) -> + A.parseEither + ( \o -> do + txt <- o A..: keyName + if txt `elem` enumValues + then pure txt + else + fail $ + "invalid enum member: " + <> T.unpack txt + <> ". Expected one of " + <> show enumValues + ) + x + where + keyName = T.pack $ symbolVal kn + parseEither :: forall a. A.FromJSON a => Either String a + parseEither = A.parseEither (A..: keyName) x + +-- --------------------------------------------------------------------- + +-- | Defines a number property +defineNumberProperty :: + (KnownSymbol s, NotElem s r) => + KeyNameProxy s -> + -- | description + T.Text -> + -- | default value + Double -> + Properties r -> + Properties ('PropertyKey s 'TNumber : r) +defineNumberProperty kn description defaultValue = + insert kn SNumber MetaData {..} + +-- | Defines an integer property +defineIntegerProperty :: + (KnownSymbol s, NotElem s r) => + KeyNameProxy s -> + -- | description + T.Text -> + -- | default value + Int -> + Properties r -> + Properties ('PropertyKey s 'TInteger : r) +defineIntegerProperty kn description defaultValue = + insert kn SInteger MetaData {..} + +-- | Defines a string property +defineStringProperty :: + (KnownSymbol s, NotElem s r) => + KeyNameProxy s -> + -- | description + T.Text -> + -- | default value + T.Text -> + Properties r -> + Properties ('PropertyKey s 'TString : r) +defineStringProperty kn description defaultValue = + insert kn SString MetaData {..} + +-- | Defines a boolean property +defineBooleanProperty :: + (KnownSymbol s, NotElem s r) => + KeyNameProxy s -> + -- | description + T.Text -> + -- | default value + Bool -> + Properties r -> + Properties ('PropertyKey s 'TBoolean : r) +defineBooleanProperty kn description defaultValue = + insert kn SBoolean MetaData {..} + +-- | Defines an object property +defineObjectProperty :: + forall s r. + (KnownSymbol s, NotElem s r) => + KeyNameProxy s -> + -- | description + T.Text -> + -- | default value + A.Object -> + Properties r -> + Properties ('PropertyKey s 'TObject : r) +defineObjectProperty kn description defaultValue = + insert kn SObject MetaData {..} + +-- | Defines an array property +defineArrayProperty :: + (KnownSymbol s, NotElem s r) => + KeyNameProxy s -> + -- | description + T.Text -> + -- | default value + A.Array -> + Properties r -> + Properties ('PropertyKey s 'TArray : r) +defineArrayProperty kn description defaultValue = + insert kn SArray MetaData {..} + +-- | Defines an enum property +defineEnumProperty :: + (KnownSymbol s, NotElem s r) => + KeyNameProxy s -> + -- | description + T.Text -> + -- | valid enum members with each of description + [(T.Text, T.Text)] -> + T.Text -> + Properties r -> + Properties ('PropertyKey s 'TEnum : r) +defineEnumProperty kn description enums defaultValue = + insert kn SEnum $ EnumMetaData defaultValue description (fst <$> enums) (snd <$> enums) + +-- --------------------------------------------------------------------- + +-- | Converts a properties definition into kv pairs with default values from 'MetaData' +toDefaultJSON :: Properties r -> [A.Pair] +toDefaultJSON (Properties p) = [toEntry s v | (s, v) <- Map.toList p] + where + toEntry :: String -> SomePropertyKeyWithMetaData -> A.Pair + toEntry (T.pack -> s) = \case + (SomePropertyKeyWithMetaData SNumber MetaData {..}) -> + s A..= defaultValue + (SomePropertyKeyWithMetaData SInteger MetaData {..}) -> + s A..= defaultValue + (SomePropertyKeyWithMetaData SString MetaData {..}) -> + s A..= defaultValue + (SomePropertyKeyWithMetaData SBoolean MetaData {..}) -> + s A..= defaultValue + (SomePropertyKeyWithMetaData SObject MetaData {..}) -> + s A..= defaultValue + (SomePropertyKeyWithMetaData SArray MetaData {..}) -> + s A..= defaultValue + (SomePropertyKeyWithMetaData SEnum EnumMetaData {..}) -> + s A..= defaultValue + +-- | Converts a properties definition into kv pairs as vscode schema +toVSCodeExtensionSchema :: T.Text -> Properties r -> [A.Pair] +toVSCodeExtensionSchema prefix (Properties p) = + [(prefix <> T.pack k) A..= toEntry v | (k, v) <- Map.toList p] + where + toEntry :: SomePropertyKeyWithMetaData -> A.Value + toEntry = \case + (SomePropertyKeyWithMetaData SNumber MetaData {..}) -> + A.object + [ "type" A..= A.String "number", + "markdownDescription" A..= description, + "default" A..= defaultValue, + "scope" A..= A.String "resource" + ] + (SomePropertyKeyWithMetaData SInteger MetaData {..}) -> + A.object + [ "type" A..= A.String "integer", + "markdownDescription" A..= description, + "default" A..= defaultValue, + "scope" A..= A.String "resource" + ] + (SomePropertyKeyWithMetaData SString MetaData {..}) -> + A.object + [ "type" A..= A.String "string", + "markdownDescription" A..= description, + "default" A..= defaultValue, + "scope" A..= A.String "resource" + ] + (SomePropertyKeyWithMetaData SBoolean MetaData {..}) -> + A.object + [ "type" A..= A.String "boolean", + "markdownDescription" A..= description, + "default" A..= defaultValue, + "scope" A..= A.String "resource" + ] + (SomePropertyKeyWithMetaData SObject MetaData {..}) -> + A.object + [ "type" A..= A.String "object", + "markdownDescription" A..= description, + "default" A..= defaultValue, + "scope" A..= A.String "resource" + ] + (SomePropertyKeyWithMetaData SArray MetaData {..}) -> + A.object + [ "type" A..= A.String "array", + "markdownDescription" A..= description, + "default" A..= defaultValue, + "scope" A..= A.String "resource" + ] + (SomePropertyKeyWithMetaData SEnum EnumMetaData {..}) -> + A.object + [ "type" A..= A.String "string", + "description" A..= description, + "enum" A..= enumValues, + "enumDescriptions" A..= enumDescriptions, + "default" A..= defaultValue, + "scope" A..= A.String "resource" + ] diff --git a/hls-plugin-api/src/Ide/PluginUtils.hs b/hls-plugin-api/src/Ide/PluginUtils.hs index 1742d2c2ea..d0ae8d8132 100644 --- a/hls-plugin-api/src/Ide/PluginUtils.hs +++ b/hls-plugin-api/src/Ide/PluginUtils.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} module Ide.PluginUtils ( WithDeletions(..), getProcessID, @@ -19,7 +20,11 @@ module Ide.PluginUtils mkLspCommand, mkLspCmdId, getPid, - allLspCmdIds,allLspCmdIds',installSigUsr1Handler, subRange) + allLspCmdIds, + allLspCmdIds', + installSigUsr1Handler, + subRange, + usePropertyLsp) where @@ -34,6 +39,7 @@ import Language.LSP.Types.Capabilities import qualified Data.Map.Strict as Map import Ide.Plugin.Config +import Ide.Plugin.Properties import Language.LSP.Server -- --------------------------------------------------------------------- @@ -161,6 +167,19 @@ getPluginConfig plugin = do -- --------------------------------------------------------------------- +-- | Returns the value of a property defined by the current plugin. +usePropertyLsp :: + (HasProperty s k t r, MonadLsp Config m) => + KeyNameProxy s -> + PluginId -> + Properties r -> + m (ToHsType t) +usePropertyLsp kn pId p = do + config <- getPluginConfig pId + return $ useProperty kn p $ plcConfig <$> config + +-- --------------------------------------------------------------------- + extractRange :: Range -> T.Text -> T.Text extractRange (Range (Position sl _) (Position el _)) s = newS where focusLines = take (el-sl+1) $ drop sl $ T.lines s diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index 57206a0625..f9585a16c1 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -41,6 +41,7 @@ import Data.Text.Encoding (encodeUtf8) import Development.Shake hiding (command) import GHC.Generics import Ide.Plugin.Config +import Ide.Plugin.Properties import Language.LSP.Server (LspM, getVirtualFile) import Language.LSP.Types import Language.LSP.Types.Capabilities @@ -58,12 +59,22 @@ newtype IdePlugins ideState = IdePlugins -- --------------------------------------------------------------------- data PluginDescriptor ideState = - PluginDescriptor { pluginId :: !PluginId - , pluginRules :: !(Rules ()) - , pluginCommands :: ![PluginCommand ideState] - , pluginHandlers :: PluginHandlers ideState + PluginDescriptor { pluginId :: !PluginId + , pluginRules :: !(Rules ()) + , pluginCommands :: ![PluginCommand ideState] + , pluginHandlers :: PluginHandlers ideState + , pluginCustomConfig :: CustomConfig } +-- | An existential wrapper of 'Properties', used only for documenting and generating config templates +data CustomConfig = forall r. CustomConfig (Properties r) + +emptyCustomConfig :: CustomConfig +emptyCustomConfig = CustomConfig emptyProperties + +mkCustomConfig :: Properties r -> CustomConfig +mkCustomConfig = CustomConfig + -- | Methods that can be handled by plugins. -- 'ExtraParams' captures any extra data the IDE passes to the handlers for this method -- Only methods for which we know how to combine responses can be instances of 'PluginMethod' @@ -221,6 +232,7 @@ defaultPluginDescriptor plId = mempty mempty mempty + emptyCustomConfig newtype CommandId = CommandId T.Text deriving (Show, Read, Eq, Ord) diff --git a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs index a7724570c5..417cc0e4ea 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs @@ -8,8 +8,6 @@ import Control.Arrow import Control.Monad import Control.Monad.State (State, get, put, evalState) import Control.Monad.Trans.Maybe -import Data.Aeson (Value (Object), fromJSON) -import Data.Aeson.Types (Result (Error, Success)) import Data.Coerce import Data.Functor ((<&>)) import Data.Generics.Aliases (mkQ) @@ -20,7 +18,6 @@ import Data.Monoid import qualified Data.Set as S import qualified Data.Text as T import Data.Traversable -import Development.IDE (ShakeExtras, getPluginConfig) import Development.IDE.Core.PositionMapping import Development.IDE.Core.RuleTypes import Development.IDE.Core.Service (runAction) @@ -32,8 +29,10 @@ import Development.Shake (Action, RuleResult) import Development.Shake.Classes (Typeable, Binary, Hashable, NFData) import qualified FastString import GhcPlugins (tupleDataCon, consDataCon, substTyAddInScope) -import Ide.Plugin.Config (PluginConfig (plcConfig)) +import Ide.Types (PluginId) import qualified Ide.Plugin.Config as Plugin +import Ide.PluginUtils (usePropertyLsp) +import Ide.Plugin.Properties import Language.LSP.Server (MonadLsp, sendNotification) import Language.LSP.Types import OccName @@ -77,18 +76,27 @@ runStaleIde state nfp a = MaybeT $ runIde state $ useWithStale a nfp ------------------------------------------------------------------------------ --- | Get the the plugin config -getTacticConfig :: MonadLsp Plugin.Config m => ShakeExtras -> m Config -getTacticConfig extras = do - pcfg <- getPluginConfig extras "tactics" - pure $ case fromJSON $ Object $ plcConfig pcfg of - Success cfg -> cfg - Error _ -> emptyConfig + +properties :: Properties + '[ 'PropertyKey "max_use_ctor_actions" 'TInteger, + 'PropertyKey "features" 'TString] +properties = emptyProperties + & defineStringProperty #features + "Feature set used by Wingman" "" + & defineIntegerProperty #max_use_ctor_actions + "Maximum number of `Use constructor ` code actions that can appear" 5 +-- | Get the the plugin config +getTacticConfig :: MonadLsp Plugin.Config m => PluginId -> m Config +getTacticConfig pId = + Config + <$> (parseFeatureSet <$> usePropertyLsp #features pId properties) + <*> usePropertyLsp #max_use_ctor_actions pId properties + ------------------------------------------------------------------------------ -- | Get the current feature set from the plugin config. -getFeatureSet :: MonadLsp Plugin.Config m => ShakeExtras -> m FeatureSet +getFeatureSet :: MonadLsp Plugin.Config m => PluginId -> m FeatureSet getFeatureSet = fmap cfg_feature_set . getTacticConfig @@ -356,4 +364,3 @@ mkShowMessageParams ufm = ShowMessageParams (ufmSeverity ufm) $ T.pack $ show uf showLspMessage :: MonadLsp cfg m => ShowMessageParams -> m () showLspMessage = sendNotification SWindowShowMessage - diff --git a/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs b/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs index 9c861d827c..a2b84ad807 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs @@ -44,18 +44,18 @@ descriptor plId = (defaultPluginDescriptor plId) PluginCommand (tcCommandId tc) (tacticDesc $ tcCommandName tc) - (tacticCmd $ commandTactic tc)) + (tacticCmd (commandTactic tc) plId)) [minBound .. maxBound] , pluginHandlers = mkPluginHandler STextDocumentCodeAction codeActionProvider + , pluginCustomConfig = + mkCustomConfig properties } - - codeActionProvider :: PluginMethodHandler IdeState TextDocumentCodeAction codeActionProvider state plId (CodeActionParams _ _ (TextDocumentIdentifier uri) range _ctx) | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = do - cfg <- getTacticConfig $ shakeExtras state + cfg <- getTacticConfig plId liftIO $ fromMaybeT (Right $ List []) $ do (_, jdg, _, dflags) <- judgementForHole state nfp range $ cfg_feature_set cfg actions <- lift $ @@ -81,10 +81,10 @@ showUserFacingMessage ufm = do pure $ Left $ mkErr InternalError $ T.pack $ show ufm -tacticCmd :: (OccName -> TacticsM ()) -> CommandFunction IdeState TacticParams -tacticCmd tac state (TacticParams uri range var_name) +tacticCmd :: (OccName -> TacticsM ()) -> PluginId -> CommandFunction IdeState TacticParams +tacticCmd tac pId state (TacticParams uri range var_name) | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = do - features <- getFeatureSet $ shakeExtras state + features <- getFeatureSet pId ccs <- getClientCapabilities res <- liftIO $ runMaybeT $ do (range', jdg, ctx, dflags) <- judgementForHole state nfp range features @@ -111,7 +111,7 @@ tacticCmd tac state (TacticParams uri range var_name) (ApplyWorkspaceEditParams Nothing edit) (const $ pure ()) pure $ Right Null -tacticCmd _ _ _ = +tacticCmd _ _ _ _ = pure $ Left $ mkErr InvalidRequest "Bad URI" diff --git a/plugins/hls-tactics-plugin/src/Wingman/Types.hs b/plugins/hls-tactics-plugin/src/Wingman/Types.hs index 71e58ef68f..cf5aa9655d 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Types.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Types.hs @@ -15,15 +15,13 @@ module Wingman.Types ) where import ConLike (ConLike) -import Control.Lens hiding (Context, (.=)) +import Control.Lens hiding (Context) import Control.Monad.Reader import Control.Monad.State -import Data.Aeson import Data.Coerce import Data.Function import Data.Generics.Product (field) import Data.List.NonEmpty (NonEmpty (..)) -import Data.Maybe (fromMaybe) import Data.Semigroup import Data.Set (Set) import Data.Text (Text) @@ -82,25 +80,6 @@ data Config = Config , cfg_max_use_ctor_actions :: Int } -emptyConfig :: Config -emptyConfig = Config defaultFeatures 5 - - -instance ToJSON Config where - toJSON Config{..} = object - [ "features" .= prettyFeatureSet cfg_feature_set - , "max_use_ctor_actions" .= cfg_max_use_ctor_actions - ] - -instance FromJSON Config where - parseJSON = withObject "Config" $ \obj -> do - cfg_feature_set <- - parseFeatureSet . fromMaybe "" <$> obj .:? "features" - cfg_max_use_ctor_actions <- - fromMaybe 5 <$> obj .:? "max_use_ctor_actions" - pure $ Config{..} - - ------------------------------------------------------------------------------ -- | A wrapper around 'Type' which supports equality and ordering. newtype CType = CType { unCType :: Type } diff --git a/plugins/hls-tactics-plugin/test/Server.hs b/plugins/hls-tactics-plugin/test/Server.hs index fd7f14fa9e..9b1c88b5f8 100644 --- a/plugins/hls-tactics-plugin/test/Server.hs +++ b/plugins/hls-tactics-plugin/test/Server.hs @@ -11,7 +11,7 @@ import Ide.PluginUtils main :: IO () main = defaultMain def { argsHlsPlugins = pluginDescToIdePlugins $ - [ T.descriptor "tactic" + [ T.descriptor "tactics" ] <> Ghcide.descriptors } diff --git a/plugins/hls-tactics-plugin/test/Utils.hs b/plugins/hls-tactics-plugin/test/Utils.hs index 6ede016ae7..87c0dcefb1 100644 --- a/plugins/hls-tactics-plugin/test/Utils.hs +++ b/plugins/hls-tactics-plugin/test/Utils.hs @@ -8,7 +8,7 @@ module Utils where import Control.Applicative.Combinators (skipManyTill) -import Control.Lens hiding (failing, (<.>)) +import Control.Lens hiding (failing, (<.>), (.=)) import Control.Monad (unless) import Control.Monad.IO.Class import Data.Aeson @@ -19,7 +19,7 @@ import Data.Maybe import Data.Text (Text) import qualified Data.Text.IO as T import qualified Ide.Plugin.Config as Plugin -import Wingman.FeatureSet (FeatureSet, allFeatures) +import Wingman.FeatureSet (FeatureSet, allFeatures, prettyFeatureSet) import Wingman.LanguageServer (mkShowMessageParams) import Wingman.Types import Language.LSP.Test @@ -83,8 +83,7 @@ setFeatureSet features = do config = def_config { Plugin.plugins = M.fromList [("tactics", - def { Plugin.plcConfig = unObject $ toJSON $ - emptyConfig { cfg_feature_set = features }} + def { Plugin.plcConfig = unObject $ object ["features" .= prettyFeatureSet features] } )] <> Plugin.plugins def_config } sendNotification SWorkspaceDidChangeConfiguration $ diff --git a/src/Ide/Arguments.hs b/src/Ide/Arguments.hs index 643769b2c9..efbae93621 100644 --- a/src/Ide/Arguments.hs +++ b/src/Ide/Arguments.hs @@ -29,6 +29,8 @@ data Arguments | ProbeToolsMode | DbCmd Options Command | LspMode LspArguments + | VSCodeExtensionSchemaMode + | DefaultConfigurationMode data LspArguments = LspArguments {argLSP :: Bool @@ -58,7 +60,9 @@ getArguments exeName = execParser opts VersionMode <$> printVersionParser exeName <|> probeToolsParser exeName <|> hsubparser (command "hiedb" (info (DbCmd <$> optParser "" True <*> cmdParser <**> helper) hieInfo)) - <|> LspMode <$> arguments) + <|> LspMode <$> arguments + <|> vsCodeExtensionSchemaModeParser + <|> defaultConfigurationModeParser) <**> helper) ( fullDesc <> progDesc "Used as a test bed to check your IDE Client will work" @@ -77,6 +81,16 @@ probeToolsParser exeName = flag' ProbeToolsMode (long "probe-tools" <> help ("Show " ++ exeName ++ " version and other tools of interest")) +vsCodeExtensionSchemaModeParser :: Parser Arguments +vsCodeExtensionSchemaModeParser = + flag' VSCodeExtensionSchemaMode + (long "vscode-extension-schema" <> help "Print generic config schema for plugins (used in the package.json of haskell vscode extension)") + +defaultConfigurationModeParser :: Parser Arguments +defaultConfigurationModeParser = + flag' DefaultConfigurationMode + (long "generate-default-config" <> help "Print config supported by the server with default values") + arguments :: Parser LspArguments arguments = LspArguments <$> switch (long "lsp" <> help "Start talking to an LSP server") diff --git a/src/Ide/Main.hs b/src/Ide/Main.hs index 0f443fbfb8..b0396159f1 100644 --- a/src/Ide/Main.hs +++ b/src/Ide/Main.hs @@ -1,34 +1,38 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 -{-# LANGUAGE CPP #-} -- To get precise GHC version +{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -Wno-dodgy-imports #-} -- GHC no longer exports def in GHC 8.6 and above -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilies #-} module Ide.Main(defaultMain, runLspMode) where -import Control.Monad.Extra -import qualified Data.Map.Strict as Map -import qualified Data.Text as T -import Development.IDE.Core.Rules -import Development.IDE.Session (setInitialDynFlags, getHieDbLoc) -import Development.IDE.Types.Logger as G -import qualified Language.LSP.Server as LSP -import Ide.Arguments -import Ide.Logger -import Ide.Version -import Ide.Types (IdePlugins, ipMap) -import qualified System.Directory.Extra as IO -import System.Exit -import System.IO -import qualified System.Log.Logger as L -import HieDb.Run -import qualified Development.IDE.Main as Main +import Control.Monad.Extra +import qualified Data.Aeson.Encode.Pretty as A +import qualified Data.ByteString.Lazy.Char8 as LBS +import Data.Default +import qualified Data.Map.Strict as Map +import qualified Data.Text as T +import Development.IDE.Core.Rules +import qualified Development.IDE.Main as Main +import Development.IDE.Session (getHieDbLoc, setInitialDynFlags) +import Development.IDE.Types.Logger as G import qualified Development.IDE.Types.Options as Ghcide -import Development.Shake (ShakeOptions(shakeThreads)) -import Data.Default +import Development.Shake (ShakeOptions (shakeThreads)) +import HieDb.Run +import Ide.Arguments +import Ide.Logger +import Ide.Plugin.ConfigUtils (pluginsToDefaultConfig, + pluginsToVSCodeExtensionSchema) +import Ide.Types (IdePlugins, ipMap) +import Ide.Version +import qualified Language.LSP.Server as LSP +import qualified System.Directory.Extra as IO +import System.Exit +import System.IO +import qualified System.Log.Logger as L defaultMain :: Arguments -> IdePlugins IdeState -> IO () defaultMain args idePlugins = do @@ -64,6 +68,12 @@ defaultMain args idePlugins = do hPutStrLn stderr hlsVer runLspMode lspArgs idePlugins + VSCodeExtensionSchemaMode -> do + LBS.putStrLn $ A.encodePretty $ pluginsToVSCodeExtensionSchema idePlugins + + DefaultConfigurationMode -> do + LBS.putStrLn $ A.encodePretty $ pluginsToDefaultConfig idePlugins + -- --------------------------------------------------------------------- hlsLogger :: G.Logger