From cc8e4fde589fdb5f3f54f885bd48e173877464af Mon Sep 17 00:00:00 2001 From: Potato Hatsue <1793913507@qq.com> Date: Mon, 15 Mar 2021 14:48:05 +0800 Subject: [PATCH 01/13] Support declarative custom config, add --vscode-extension-schema --- ghcide/exe/Arguments.hs | 22 +- ghcide/exe/Main.hs | 11 + ghcide/ghcide.cabal | 3 +- .../src/Development/IDE/Plugin/TypeLenses.hs | 42 +-- haskell-language-server.cabal | 1 + hls-plugin-api/hls-plugin-api.cabal | 2 + hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs | 41 +++ hls-plugin-api/src/Ide/Plugin/Properties.hs | 339 ++++++++++++++++++ hls-plugin-api/src/Ide/PluginUtils.hs | 28 +- hls-plugin-api/src/Ide/Types.hs | 20 +- src/Ide/Arguments.hs | 9 +- src/Ide/Main.hs | 52 +-- 12 files changed, 508 insertions(+), 62 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/ghcide/exe/Arguments.hs b/ghcide/exe/Arguments.hs index f78202a8f0..50d3133421 100644 --- a/ghcide/exe/Arguments.hs +++ b/ghcide/exe/Arguments.hs @@ -11,16 +11,17 @@ 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 + ,argsVSCodeExtensionConfig :: Bool + ,argsShakeProfiling :: Maybe FilePath + ,argsOTMemoryProfiling :: Bool + ,argsTesting :: Bool + ,argsDisableKick :: Bool + ,argsThreads :: Int + ,argsVerbose :: Bool + ,argFilesOrCmd :: a } getArguments :: IO Arguments @@ -35,6 +36,7 @@ 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)") <*> 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..4d97dd4e93 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,7 @@ 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 (pluginsToVSCodeExtensionSchema) import Ide.PluginUtils (pluginDescToIdePlugins) import Paths_ghcide (version) import qualified System.Directory.Extra as IO @@ -58,6 +62,13 @@ main = do if argsVersion then ghcideVersion >>= putStrLn >> exitSuccess else hPutStrLn stderr {- see WARNING above -} =<< ghcideVersion + let hlsPlugins = pluginDescToIdePlugins GhcIde.descriptors + + when argsVSCodeExtensionConfig $ do + LT.putStrLn $ decodeUtf8 $ A.encodePretty $ pluginsToVSCodeExtensionSchema hlsPlugins + exitSuccess + + whenJust argsCwd IO.setCurrentDirectory -- lock to avoid overlapping output on stdout diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 5a3112417b..2fb1ca3081 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..085f97cffc 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -13,16 +13,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 +48,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 +87,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 +208,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 +244,12 @@ 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 + _ -> 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..d5b9584caa --- /dev/null +++ b/hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} + +module Ide.Plugin.ConfigUtils where + +import qualified Data.Aeson as A +import qualified Data.Dependent.Map as DMap +import qualified Data.Dependent.Sum as DSum +import qualified Data.Map as Map +import Ide.Plugin.Properties (toVSCodeExtensionSchema) +import Ide.Types +import Language.LSP.Types + +pluginsToVSCodeExtensionSchema :: IdePlugins a -> A.Value +pluginsToVSCodeExtensionSchema IdePlugins {..} = A.object $ mconcat $ singlePlugin <$> Map.elems ipMap + where + singlePlugin PluginDescriptor {..} = genericConfig <> dedicatedConfig + where + (PluginHandlers (DMap.toList -> handlers)) = pluginHandlers + customConfigToDedicatedConfig (CustomConfig p) = toVSCodeExtensionSchema (withIdPrefix "config.") p + (PluginId pId) = pluginId + genericConfig = mconcat $ handlersToGenericConfig <$> handlers + dedicatedConfig = customConfigToDedicatedConfig pluginCustomConfig + handlersToGenericConfig (IdeMethod m DSum.:=> _) = case m of + STextDocumentCodeAction -> [withIdPrefix "codeActionsOn" A..= methodEntry "code actions"] + STextDocumentCodeLens -> [withIdPrefix "codeLensOn" A..= methodEntry "code lenses"] + STextDocumentRename -> [withIdPrefix "renameOn" A..= methodEntry "rename"] + STextDocumentHover -> [withIdPrefix "hoverOn" A..= methodEntry "hover"] + STextDocumentDocumentSymbol -> [withIdPrefix "symbolsOn" A..= methodEntry "symbols"] + STextDocumentCompletion -> [withIdPrefix "completionOn" A..= methodEntry "completions"] + _ -> [] + methodEntry 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..c9a03401aa --- /dev/null +++ b/hls-plugin-api/src/Ide/Plugin/Properties.hs @@ -0,0 +1,339 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +-- See the note on 'find' +{-# OPTIONS_GHC -Wno-redundant-constraints #-} + +module Ide.Plugin.Properties + ( PropertyType (..), + ToHsType, + MetaData (..), + PropertyKey, + SPropertyKey (..), + Properties, + HasProperty, + emptyProperties, + defineNumberProperty, + 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 Data.Proxy (Proxy (..)) +import qualified Data.Text as T +import GHC.TypeLits +import Unsafe.Coerce (unsafeCoerce) + +-- --------------------------------------------------------------------- + +data PropertyType + = TNumber + | TString + | TBoolean + | TObject + | TArray + | TEnum + +type family ToHsType (t :: PropertyType) where + ToHsType 'TNumber = Int + ToHsType 'TString = T.Text + ToHsType 'TBoolean = Bool + ToHsType 'TObject = A.Object + ToHsType 'TArray = A.Array + ToHsType 'TEnum = T.Text -- supports only text enum now + +-- --------------------------------------------------------------------- + +data MetaData (t :: PropertyType) where + MetaData :: + (IsNotTEnum t) => + {defaultValue :: ToHsType t, description :: T.Text} -> + MetaData t + EnumMetaData :: + (IsTEnum t) => + { defaultValue :: ToHsType t, + description :: T.Text, + enumValues :: [T.Text], + enumDescriptions :: [T.Text] + } -> + MetaData t + +data PropertyKey (s :: Symbol) (t :: PropertyType) + +data SPropertyKey k where + SNumber :: SPropertyKey (PropertyKey s 'TNumber) + 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) + +data SomePropertyKeyWithMetaData + = forall k s t. + (k ~ PropertyKey s t) => + SomePropertyKeyWithMetaData (SPropertyKey k, MetaData t) + +-- | Describes dedicated configuration of a plugin. +-- +-- It was designed to be compatible with vscode's poor settings UI +newtype Properties (r :: [*]) = Properties (Map.Map String SomePropertyKeyWithMetaData) + +-- --------------------------------------------------------------------- + +type family IsTEnum (t :: PropertyType) :: Constraint where + IsTEnum 'TEnum = () + IsTEnum x = TypeError ('Text "Expected ‘" ':<>: 'ShowType 'TEnum ':<>: 'Text "’, but got ‘" ':<>: 'ShowType x ':<>: 'Text "’") + +type family IsNotTEnum (t :: PropertyType) :: Constraint where + IsNotTEnum 'TEnum = TypeError ('Text "Unexpected " ':<>: 'ShowType 'TEnum) + IsNotTEnum x = () + +type family FindKey (s :: Symbol) r where + FindKey s (PropertyKey s t ': _) = t + FindKey s (_ ': xs) = FindKey s xs + +type family Elem (s :: Symbol) r :: Constraint where + Elem s (PropertyKey s _ ': _) = () + Elem s (_ ': xs) = Elem s xs + Elem s '[] = TypeError ('Text "The key ‘" ':<>: 'Text s ':<>: 'Text "’ is undefined") + +type family NotElem (s :: Symbol) r :: Constraint where + NotElem s (PropertyKey s _ ': _) = TypeError ('Text "The key ‘" ':<>: 'Text s ':<>: 'Text "’ is already defined") + NotElem s (_ ': xs) = NotElem s xs + NotElem s '[] = () + +type HasProperty s k t r = (k ~ PropertyKey s t, Elem s r, FindKey s r ~ t, KnownSymbol s) + +-- --------------------------------------------------------------------- + +emptyProperties :: Properties '[] +emptyProperties = Properties Map.empty + +insert :: + forall s k r t. + (k ~ PropertyKey s t, NotElem s r, KnownSymbol s) => + SPropertyKey k -> + MetaData t -> + Properties r -> + Properties (k ': r) +insert key metadata (Properties old) = Properties (Map.insert (symbolVal (Proxy @s)) (SomePropertyKeyWithMetaData (key, metadata)) old) + +find :: + forall s k r t. + (HasProperty s k t r) => + Properties r -> + (SPropertyKey k, MetaData t) +find (Properties p) = case p Map.! symbolVal (Proxy @s) of + (SomePropertyKeyWithMetaData x) -> + -- 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 (that's why constraints will be considered as redundant by GHC), + -- but encode it using semantically identical 'Map' at term level, + -- which avoids inducting on the list by defining a new type class. + unsafeCoerce x + +-- --------------------------------------------------------------------- + +-- | Given the name of a defined property, generates a JSON parser of 'plcConfig' +usePropertyEither :: + forall s k t r. + (HasProperty s k t r) => + Properties r -> + A.Object -> + Either String (ToHsType t) +usePropertyEither p = parseProperty @s (find p) + +-- | Like 'usePropertyEither' but returns 'defaultValue' on parse error +useProperty :: + forall s k t r. + (HasProperty s k t r) => + Properties r -> + Maybe A.Object -> + ToHsType t +useProperty p = maybe (defaultValue metadata) (fromRight (defaultValue metadata) . usePropertyEither @s p) + where + (_, metadata) = find @s p + +parseProperty :: + forall s k t. + (k ~ PropertyKey s t, KnownSymbol s) => + (SPropertyKey k, MetaData t) -> + A.Object -> + Either String (ToHsType t) +parseProperty km x = case km of + (SNumber, _) -> 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 $ "unknown enum option: " <> T.unpack txt + ) + x + _ -> error "impossible" + where + keyName = T.pack $ symbolVal (Proxy @s) + parseEither :: forall a. A.FromJSON a => Either String a + parseEither = A.parseEither (A..: keyName) x + +-- --------------------------------------------------------------------- + +defineNumberProperty :: + forall s r. + (KnownSymbol s, NotElem s r) => + T.Text -> + Int -> + Properties r -> + Properties (PropertyKey s 'TNumber : r) +defineNumberProperty description defaultValue = insert SNumber MetaData {..} + +defineStringProperty :: + forall s r. + (KnownSymbol s, NotElem s r) => + T.Text -> + T.Text -> + Properties r -> + Properties (PropertyKey s 'TString : r) +defineStringProperty description defaultValue = insert SString MetaData {..} + +defineBooleanProperty :: + forall s r. + (KnownSymbol s, NotElem s r) => + T.Text -> + Bool -> + Properties r -> + Properties (PropertyKey s 'TBoolean : r) +defineBooleanProperty description defaultValue = insert SBoolean MetaData {..} + +defineObjectProperty :: + forall s r. + (KnownSymbol s, NotElem s r) => + T.Text -> + A.Object -> + Properties r -> + Properties (PropertyKey s 'TObject : r) +defineObjectProperty description defaultValue = insert SObject MetaData {..} + +defineArrayProperty :: + forall s r. + (KnownSymbol s, NotElem s r) => + T.Text -> + A.Array -> + Properties r -> + Properties (PropertyKey s 'TArray : r) +defineArrayProperty description defaultValue = insert SArray MetaData {..} + +defineEnumProperty :: + forall s r. + (KnownSymbol s, NotElem s r) => + T.Text -> + [(T.Text, T.Text)] -> + T.Text -> + Properties r -> + Properties (PropertyKey s 'TEnum : r) +defineEnumProperty description enums defaultValue = insert SEnum $ EnumMetaData defaultValue description (fst <$> enums) (snd <$> enums) + +-- --------------------------------------------------------------------- + +toDefaultJSON :: Properties r -> A.Value +toDefaultJSON (Properties p) = + A.object ["config" A..= A.object [toEntry k v | (k, v) <- Map.toList p]] + where + toEntry :: String -> SomePropertyKeyWithMetaData -> A.Pair + toEntry s (SomePropertyKeyWithMetaData k) = case k of + (SNumber, MetaData {..}) -> + T.pack s A..= defaultValue + (SString, MetaData {..}) -> + T.pack s A..= defaultValue + (SBoolean, MetaData {..}) -> + T.pack s A..= defaultValue + (SObject, MetaData {..}) -> + T.pack s A..= defaultValue + (SArray, MetaData {..}) -> + T.pack s A..= defaultValue + (SEnum, EnumMetaData {..}) -> + T.pack s A..= defaultValue + _ -> error "impossible" + +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 (SomePropertyKeyWithMetaData k) = case k of + (SNumber, MetaData {..}) -> + A.object + [ "type" A..= A.String "number", + "markdownDescription" A..= description, + "default" A..= defaultValue, + "scope" A..= A.String "resource" + ] + (SString, MetaData {..}) -> + A.object + [ "type" A..= A.String "string", + "markdownDescription" A..= description, + "default" A..= defaultValue, + "scope" A..= A.String "resource" + ] + (SBoolean, MetaData {..}) -> + A.object + [ "type" A..= A.String "boolean", + "markdownDescription" A..= description, + "default" A..= defaultValue, + "scope" A..= A.String "resource" + ] + (SObject, MetaData {..}) -> + A.object + [ "type" A..= A.String "object", + "markdownDescription" A..= description, + "default" A..= defaultValue, + "scope" A..= A.String "resource" + ] + (SArray, MetaData {..}) -> + A.object + [ "type" A..= A.String "array", + "markdownDescription" A..= description, + "default" A..= defaultValue, + "scope" A..= A.String "resource" + ] + (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" + ] + _ -> error "impossible" diff --git a/hls-plugin-api/src/Ide/PluginUtils.hs b/hls-plugin-api/src/Ide/PluginUtils.hs index 1742d2c2ea..600175e434 100644 --- a/hls-plugin-api/src/Ide/PluginUtils.hs +++ b/hls-plugin-api/src/Ide/PluginUtils.hs @@ -1,5 +1,9 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} module Ide.PluginUtils ( WithDeletions(..), getProcessID, @@ -19,7 +23,11 @@ module Ide.PluginUtils mkLspCommand, mkLspCmdId, getPid, - allLspCmdIds,allLspCmdIds',installSigUsr1Handler, subRange) + allLspCmdIds, + allLspCmdIds', + installSigUsr1Handler, + subRange, + usePropertyLsp) where @@ -34,6 +42,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 +170,19 @@ getPluginConfig plugin = do -- --------------------------------------------------------------------- +-- | Returns the value of a property defined by the current plugin. +usePropertyLsp :: + forall s k t r m. + (HasProperty s k t r, MonadLsp Config m) => + PluginId -> + Properties r -> + m (ToHsType t) +usePropertyLsp pId p = do + config <- getPluginConfig pId + return $ useProperty @s 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/src/Ide/Arguments.hs b/src/Ide/Arguments.hs index 643769b2c9..d925368a82 100644 --- a/src/Ide/Arguments.hs +++ b/src/Ide/Arguments.hs @@ -29,6 +29,7 @@ data Arguments | ProbeToolsMode | DbCmd Options Command | LspMode LspArguments + | VSCodeExtensionSchemaMode data LspArguments = LspArguments {argLSP :: Bool @@ -58,7 +59,8 @@ getArguments exeName = execParser opts VersionMode <$> printVersionParser exeName <|> probeToolsParser exeName <|> hsubparser (command "hiedb" (info (DbCmd <$> optParser "" True <*> cmdParser <**> helper) hieInfo)) - <|> LspMode <$> arguments) + <|> LspMode <$> arguments + <|> vsCodeExtensionConfigModeParser) <**> helper) ( fullDesc <> progDesc "Used as a test bed to check your IDE Client will work" @@ -77,6 +79,11 @@ probeToolsParser exeName = flag' ProbeToolsMode (long "probe-tools" <> help ("Show " ++ exeName ++ " version and other tools of interest")) +vsCodeExtensionConfigModeParser :: Parser Arguments +vsCodeExtensionConfigModeParser = + flag' VSCodeExtensionSchemaMode + (long "vscode-extension-schema" <> help "Print generic config schema for plugins (used in the package.json of haskell vscode extension)") + 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..24a348ebc9 100644 --- a/src/Ide/Main.hs +++ b/src/Ide/Main.hs @@ -1,34 +1,37 @@ -- 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 (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 +67,9 @@ defaultMain args idePlugins = do hPutStrLn stderr hlsVer runLspMode lspArgs idePlugins + VSCodeExtensionSchemaMode -> do + LBS.putStrLn $ A.encodePretty $ pluginsToVSCodeExtensionSchema idePlugins + -- --------------------------------------------------------------------- hlsLogger :: G.Logger From 3a0b1011971671bf86868d005d6d23028546ca9b Mon Sep 17 00:00:00 2001 From: Potato Hatsue <1793913507@qq.com> Date: Mon, 15 Mar 2021 18:41:38 +0800 Subject: [PATCH 02/13] Add globalOn --- hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs b/hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs index d5b9584caa..47f0bd3220 100644 --- a/hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs +++ b/hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs @@ -21,7 +21,7 @@ pluginsToVSCodeExtensionSchema IdePlugins {..} = A.object $ mconcat $ singlePlug (PluginHandlers (DMap.toList -> handlers)) = pluginHandlers customConfigToDedicatedConfig (CustomConfig p) = toVSCodeExtensionSchema (withIdPrefix "config.") p (PluginId pId) = pluginId - genericConfig = mconcat $ handlersToGenericConfig <$> handlers + genericConfig = withIdPrefix "globalOn" A..= methodEntry "plugin" : mconcat (handlersToGenericConfig <$> handlers) dedicatedConfig = customConfigToDedicatedConfig pluginCustomConfig handlersToGenericConfig (IdeMethod m DSum.:=> _) = case m of STextDocumentCodeAction -> [withIdPrefix "codeActionsOn" A..= methodEntry "code actions"] From 8ba5e6e09c0d1066f54f79cb99073f27116cc8cf Mon Sep 17 00:00:00 2001 From: Potato Hatsue <1793913507@qq.com> Date: Tue, 16 Mar 2021 22:12:26 +0800 Subject: [PATCH 03/13] Add --generate-default-config --- ghcide/exe/Arguments.hs | 4 +- ghcide/exe/Main.hs | 8 ++- hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs | 73 ++++++++++++++++---- hls-plugin-api/src/Ide/Plugin/Properties.hs | 16 +++-- src/Ide/Arguments.hs | 13 +++- src/Ide/Main.hs | 6 +- 6 files changed, 93 insertions(+), 27 deletions(-) diff --git a/ghcide/exe/Arguments.hs b/ghcide/exe/Arguments.hs index 50d3133421..125cf66961 100644 --- a/ghcide/exe/Arguments.hs +++ b/ghcide/exe/Arguments.hs @@ -14,7 +14,8 @@ data Arguments' a = Arguments {argLSP :: Bool ,argsCwd :: Maybe FilePath ,argsVersion :: Bool - ,argsVSCodeExtensionConfig :: Bool + ,argsVSCodeExtensionSchema :: Bool + ,argsDefaultConfig :: Bool ,argsShakeProfiling :: Maybe FilePath ,argsOTMemoryProfiling :: Bool ,argsTesting :: Bool @@ -37,6 +38,7 @@ arguments = Arguments <*> 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 4d97dd4e93..042afed11c 100644 --- a/ghcide/exe/Main.hs +++ b/ghcide/exe/Main.hs @@ -32,7 +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 (pluginsToVSCodeExtensionSchema) +import Ide.Plugin.ConfigUtils (pluginsToDefaultConfig, + pluginsToVSCodeExtensionSchema) import Ide.PluginUtils (pluginDescToIdePlugins) import Paths_ghcide (version) import qualified System.Directory.Extra as IO @@ -64,10 +65,13 @@ main = do let hlsPlugins = pluginDescToIdePlugins GhcIde.descriptors - when argsVSCodeExtensionConfig $ do + 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 diff --git a/hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs b/hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs index 47f0bd3220..e32d6c35bb 100644 --- a/hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs +++ b/hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs @@ -6,32 +6,79 @@ 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.Properties (toVSCodeExtensionSchema) +import Ide.Plugin.Config +import Ide.Plugin.Properties (toDefaultJSON, toVSCodeExtensionSchema) import Ide.Types import Language.LSP.Types +pluginsToDefaultConfig :: IdePlugins a -> A.Value +pluginsToDefaultConfig IdePlugins {..} = + A.Object $ + HMap.adjust + ( \(unsafeValueToObject -> o) -> + A.Object $ HMap.insert "plugin" elems o + ) + "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 + singlePlugin PluginDescriptor {..} = + let x = geenericDefaultConfig <> dedicatedDefaultConfig + in [pId A..= A.object x | not $ null x] + where + (PluginHandlers (DMap.toList -> handlers)) = pluginHandlers + customConfigToDedicatedDefaultConfig (CustomConfig p) = toDefaultJSON p + -- we don't generate the config section if the plugin doesn't register any of the following six methods, + -- which avoids producing redundant configuration for formatters: + -- + -- "stylish-haskell": { + -- "globalOn": true + -- } + geenericDefaultConfig = + let x = mconcat (handlersToGenericDefaultConfig <$> handlers) + in ["globalOn" A..= True | not $ null x] <> x + dedicatedDefaultConfig = + let x = customConfigToDedicatedDefaultConfig pluginCustomConfig + in ["config" A..= A.object x | not $ null x] + (PluginId pId) = pluginId + 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] + _ -> [] + pluginsToVSCodeExtensionSchema :: IdePlugins a -> A.Value pluginsToVSCodeExtensionSchema IdePlugins {..} = A.object $ mconcat $ singlePlugin <$> Map.elems ipMap where - singlePlugin PluginDescriptor {..} = genericConfig <> dedicatedConfig + singlePlugin PluginDescriptor {..} = genericSchema <> dedicatedSchema where (PluginHandlers (DMap.toList -> handlers)) = pluginHandlers - customConfigToDedicatedConfig (CustomConfig p) = toVSCodeExtensionSchema (withIdPrefix "config.") p + customConfigToDedicatedSchema (CustomConfig p) = toVSCodeExtensionSchema (withIdPrefix "config.") p (PluginId pId) = pluginId - genericConfig = withIdPrefix "globalOn" A..= methodEntry "plugin" : mconcat (handlersToGenericConfig <$> handlers) - dedicatedConfig = customConfigToDedicatedConfig pluginCustomConfig - handlersToGenericConfig (IdeMethod m DSum.:=> _) = case m of - STextDocumentCodeAction -> [withIdPrefix "codeActionsOn" A..= methodEntry "code actions"] - STextDocumentCodeLens -> [withIdPrefix "codeLensOn" A..= methodEntry "code lenses"] - STextDocumentRename -> [withIdPrefix "renameOn" A..= methodEntry "rename"] - STextDocumentHover -> [withIdPrefix "hoverOn" A..= methodEntry "hover"] - STextDocumentDocumentSymbol -> [withIdPrefix "symbolsOn" A..= methodEntry "symbols"] - STextDocumentCompletion -> [withIdPrefix "completionOn" A..= methodEntry "completions"] + 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"] _ -> [] - methodEntry desc = + schemaEntry desc = A.object [ "scope" A..= A.String "resource", "type" A..= A.String "boolean", diff --git a/hls-plugin-api/src/Ide/Plugin/Properties.hs b/hls-plugin-api/src/Ide/Plugin/Properties.hs index c9a03401aa..206255aa22 100644 --- a/hls-plugin-api/src/Ide/Plugin/Properties.hs +++ b/hls-plugin-api/src/Ide/Plugin/Properties.hs @@ -12,7 +12,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} --- See the note on 'find' +-- See Note [Constraints] {-# OPTIONS_GHC -Wno-redundant-constraints #-} module Ide.Plugin.Properties @@ -150,11 +150,13 @@ find :: (SPropertyKey k, MetaData t) find (Properties p) = case p Map.! symbolVal (Proxy @s) of (SomePropertyKeyWithMetaData x) -> - -- 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, + -- 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 (that's why constraints will be considered as redundant by GHC), - -- but encode it using semantically identical 'Map' at term level, + -- 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 x @@ -266,9 +268,9 @@ defineEnumProperty description enums defaultValue = insert SEnum $ EnumMetaData -- --------------------------------------------------------------------- -toDefaultJSON :: Properties r -> A.Value +toDefaultJSON :: Properties r -> [A.Pair] toDefaultJSON (Properties p) = - A.object ["config" A..= A.object [toEntry k v | (k, v) <- Map.toList p]] + [toEntry k v | (k, v) <- Map.toList p] where toEntry :: String -> SomePropertyKeyWithMetaData -> A.Pair toEntry s (SomePropertyKeyWithMetaData k) = case k of diff --git a/src/Ide/Arguments.hs b/src/Ide/Arguments.hs index d925368a82..efbae93621 100644 --- a/src/Ide/Arguments.hs +++ b/src/Ide/Arguments.hs @@ -30,6 +30,7 @@ data Arguments | DbCmd Options Command | LspMode LspArguments | VSCodeExtensionSchemaMode + | DefaultConfigurationMode data LspArguments = LspArguments {argLSP :: Bool @@ -60,7 +61,8 @@ getArguments exeName = execParser opts <|> probeToolsParser exeName <|> hsubparser (command "hiedb" (info (DbCmd <$> optParser "" True <*> cmdParser <**> helper) hieInfo)) <|> LspMode <$> arguments - <|> vsCodeExtensionConfigModeParser) + <|> vsCodeExtensionSchemaModeParser + <|> defaultConfigurationModeParser) <**> helper) ( fullDesc <> progDesc "Used as a test bed to check your IDE Client will work" @@ -79,11 +81,16 @@ probeToolsParser exeName = flag' ProbeToolsMode (long "probe-tools" <> help ("Show " ++ exeName ++ " version and other tools of interest")) -vsCodeExtensionConfigModeParser :: Parser Arguments -vsCodeExtensionConfigModeParser = +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 24a348ebc9..b0396159f1 100644 --- a/src/Ide/Main.hs +++ b/src/Ide/Main.hs @@ -24,7 +24,8 @@ import Development.Shake (ShakeOptions (shakeThreads)) import HieDb.Run import Ide.Arguments import Ide.Logger -import Ide.Plugin.ConfigUtils (pluginsToVSCodeExtensionSchema) +import Ide.Plugin.ConfigUtils (pluginsToDefaultConfig, + pluginsToVSCodeExtensionSchema) import Ide.Types (IdePlugins, ipMap) import Ide.Version import qualified Language.LSP.Server as LSP @@ -70,6 +71,9 @@ defaultMain args idePlugins = do VSCodeExtensionSchemaMode -> do LBS.putStrLn $ A.encodePretty $ pluginsToVSCodeExtensionSchema idePlugins + DefaultConfigurationMode -> do + LBS.putStrLn $ A.encodePretty $ pluginsToDefaultConfig idePlugins + -- --------------------------------------------------------------------- hlsLogger :: G.Logger From 9c0d0ff471e6c8dc68949f5a3469ca7d85e83983 Mon Sep 17 00:00:00 2001 From: Potato Hatsue <1793913507@qq.com> Date: Tue, 16 Mar 2021 23:29:38 +0800 Subject: [PATCH 04/13] Port tactic plugin --- .../src/Wingman/LanguageServer.hs | 77 +++++++++++-------- .../hls-tactics-plugin/src/Wingman/Plugin.hs | 32 ++++---- .../hls-tactics-plugin/src/Wingman/Types.hs | 65 ++++++---------- 3 files changed, 86 insertions(+), 88 deletions(-) diff --git a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs index a7724570c5..32652c06e8 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs @@ -6,40 +6,46 @@ module Wingman.LanguageServer where import ConLike import Control.Arrow import Control.Monad -import Control.Monad.State (State, get, put, evalState) +import Control.Monad.State (State, evalState, get, + put) 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) -import Data.Generics.Schemes (everything) -import qualified Data.Map as M +import Data.Functor ((<&>)) +import Data.Generics.Aliases (mkQ) +import Data.Generics.Schemes (everything) +import qualified Data.Map as M import Data.Maybe import Data.Monoid -import qualified Data.Set as S -import qualified Data.Text as T +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) -import Development.IDE.Core.Shake (IdeState (..), useWithStale) +import Development.IDE.Core.Service (runAction) +import Development.IDE.Core.Shake (IdeState (..), + useWithStale) import Development.IDE.GHC.Compat -import Development.IDE.GHC.Error (realSrcSpanToRange) -import Development.IDE.Spans.LocalBindings (Bindings, getDefiningBindings) -import Development.Shake (Action, RuleResult) -import Development.Shake.Classes (Typeable, Binary, Hashable, NFData) +import Development.IDE.GHC.Error (realSrcSpanToRange) +import Development.IDE.Spans.LocalBindings (Bindings, + getDefiningBindings) +import Development.Shake (Action, RuleResult) +import Development.Shake.Classes (Binary, Hashable, NFData, + Typeable) import qualified FastString -import GhcPlugins (tupleDataCon, consDataCon, substTyAddInScope) -import Ide.Plugin.Config (PluginConfig (plcConfig)) -import qualified Ide.Plugin.Config as Plugin -import Language.LSP.Server (MonadLsp, sendNotification) +import GhcPlugins (consDataCon, + substTyAddInScope, + tupleDataCon) +import qualified Ide.Plugin.Config as Plugin +import Ide.Plugin.Properties +import Ide.PluginUtils (usePropertyLsp) +import Ide.Types (PluginId) +import Language.LSP.Server (MonadLsp, + sendNotification) import Language.LSP.Types import OccName -import Prelude hiding (span) -import SrcLoc (containsSpan) -import TcRnTypes (tcg_binds) +import Prelude hiding (span) +import SrcLoc (containsSpan) +import TcRnTypes (tcg_binds) import Wingman.Context import Wingman.FeatureSet import Wingman.GHC @@ -77,18 +83,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" 'TNumber, + PropertyKey "features" 'TString] +properties = emptyProperties + & defineStringProperty @"features" + "Features set used by wingman (tactic) plugin" "" + & defineNumberProperty @"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 diff --git a/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs b/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs index d4c2d7a2bd..3f0fb6bc83 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs @@ -7,17 +7,17 @@ module Wingman.Plugin , TacticCommand (..) ) where -import Control.Exception (evaluate) +import Control.Exception (evaluate) import Control.Monad import Control.Monad.Trans import Control.Monad.Trans.Maybe import Data.Aeson -import Data.Bifunctor (first) -import Data.Foldable (for_) +import Data.Bifunctor (first) +import Data.Foldable (for_) import Data.Maybe -import Data.Proxy (Proxy(..)) -import qualified Data.Text as T -import Development.IDE.Core.Shake (IdeState (..)) +import Data.Proxy (Proxy (..)) +import qualified Data.Text as T +import Development.IDE.Core.Shake (IdeState (..)) import Development.IDE.GHC.Compat import Development.IDE.GHC.ExactPrint import Ide.Types @@ -25,13 +25,13 @@ import Language.LSP.Server import Language.LSP.Types import Language.LSP.Types.Capabilities import OccName -import Prelude hiding (span) +import Prelude hiding (span) import System.Timeout import Wingman.CaseSplit import Wingman.GHC import Wingman.LanguageServer import Wingman.LanguageServer.TacticProviders -import Wingman.Machinery (scoreSolution) +import Wingman.Machinery (scoreSolution) import Wingman.Range import Wingman.Tactics import Wingman.Types @@ -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 2f28f8d3d0..fd577c4e59 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Types.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Types.hs @@ -14,32 +14,34 @@ module Wingman.Types , Range ) where -import ConLike (ConLike) -import Control.Lens hiding (Context, (.=)) +import ConLike (ConLike) +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.Generics.Product (field) +import Data.List.NonEmpty (NonEmpty (..)) import Data.Semigroup -import Data.Set (Set) -import Data.Text (Text) -import qualified Data.Text as T +import Data.Set (Set) +import Data.Text (Text) +import qualified Data.Text as T import Data.Tree -import Development.IDE.GHC.Compat hiding (Node) -import Development.IDE.GHC.Orphans () +import Development.IDE.GHC.Compat hiding (Node) +import Development.IDE.GHC.Orphans () import Development.IDE.Types.Location import GHC.Generics -import GHC.SourceGen (var) +import GHC.SourceGen (var) import OccName import Refinery.Tactic -import System.IO.Unsafe (unsafePerformIO) -import Type (TCvSubst, Var, eqType, nonDetCmpType, emptyTCvSubst) -import UniqSupply (takeUniqFromSupply, mkSplitUniqSupply, UniqSupply) -import Unique (nonDetCmpUnique, Uniquable, getUnique, Unique) +import System.IO.Unsafe (unsafePerformIO) +import Type (TCvSubst, Var, emptyTCvSubst, + eqType, nonDetCmpType) +import UniqSupply (UniqSupply, mkSplitUniqSupply, + takeUniqFromSupply) +import Unique (Uniquable, Unique, getUnique, + nonDetCmpUnique) import Wingman.Debug import Wingman.FeatureSet @@ -82,25 +84,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 } @@ -158,9 +141,9 @@ instance Show ConLike where -- | The state that should be shared between subgoals. Extracts move towards -- the root, judgments move towards the leaves, and the state moves *sideways*. data TacticState = TacticState - { ts_skolems :: !(Set TyVar) + { ts_skolems :: !(Set TyVar) -- ^ The known skolems. - , ts_unifier :: !TCvSubst + , ts_unifier :: !TCvSubst , ts_unique_gen :: !UniqSupply } deriving stock (Show, Generic) @@ -375,17 +358,17 @@ type Trace = Rose String -- information we'd like to pass from leaves of the tactics search upwards. -- This includes the actual AST we've generated (in 'syn_val'). data Synthesized a = Synthesized - { syn_trace :: Trace + { syn_trace :: Trace -- ^ A tree describing which tactics were used produce the 'syn_val'. -- Mainly for debugging when you get the wrong answer, to see the other -- things it tried. - , syn_scoped :: Hypothesis CType + , syn_scoped :: Hypothesis CType -- ^ All of the bindings created to produce the 'syn_val'. - , syn_used_vals :: Set OccName + , syn_used_vals :: Set OccName -- ^ The values used when synthesizing the 'syn_val'. , syn_recursion_count :: Sum Int -- ^ The number of recursive calls - , syn_val :: a + , syn_val :: a } deriving (Eq, Show, Functor, Foldable, Traversable, Generic) From dfa856f0728b7c29ef32b3c5a74840f8a91b0b6a Mon Sep 17 00:00:00 2001 From: Potato Hatsue <1793913507@qq.com> Date: Tue, 16 Mar 2021 23:52:40 +0800 Subject: [PATCH 05/13] Fix build of tactic plugin test --- plugins/hls-tactics-plugin/test/Utils.hs | 31 +++++++++++++----------- 1 file changed, 17 insertions(+), 14 deletions(-) diff --git a/plugins/hls-tactics-plugin/test/Utils.hs b/plugins/hls-tactics-plugin/test/Utils.hs index 6ede016ae7..416de9c649 100644 --- a/plugins/hls-tactics-plugin/test/Utils.hs +++ b/plugins/hls-tactics-plugin/test/Utils.hs @@ -8,26 +8,30 @@ module Utils where import Control.Applicative.Combinators (skipManyTill) -import Control.Lens hiding (failing, (<.>)) -import Control.Monad (unless) +import Control.Lens hiding (failing, (.=), (<.>)) +import Control.Monad (unless) import Control.Monad.IO.Class import Data.Aeson -import Data.Default (Default (def)) +import Data.Default (Default (def)) import Data.Foldable -import qualified Data.Map as M +import qualified Data.Map as M 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.LanguageServer (mkShowMessageParams) -import Wingman.Types +import Data.Text (Text) +import qualified Data.Text.IO as T +import qualified Ide.Plugin.Config as Plugin import Language.LSP.Test import Language.LSP.Types -import Language.LSP.Types.Lens hiding (actions, applyEdit, capabilities, executeCommand, id, line, message, name, rename, title) -import System.Directory (doesFileExist) +import Language.LSP.Types.Lens hiding (actions, applyEdit, + capabilities, executeCommand, + id, line, message, name, + rename, title) +import System.Directory (doesFileExist) import System.FilePath import Test.Hspec +import Wingman.FeatureSet (FeatureSet, allFeatures, + prettyFeatureSet) +import Wingman.LanguageServer (mkShowMessageParams) +import Wingman.Types ------------------------------------------------------------------------------ @@ -83,8 +87,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 $ From a3641781bb3c40c61da35f6fe82fe110d29e7a6e Mon Sep 17 00:00:00 2001 From: Potato Hatsue <1793913507@qq.com> Date: Wed, 17 Mar 2021 13:01:00 +0800 Subject: [PATCH 06/13] Fix tactic plugin test --- plugins/hls-tactics-plugin/test/Utils.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/hls-tactics-plugin/test/Utils.hs b/plugins/hls-tactics-plugin/test/Utils.hs index 416de9c649..37a5d6faf1 100644 --- a/plugins/hls-tactics-plugin/test/Utils.hs +++ b/plugins/hls-tactics-plugin/test/Utils.hs @@ -86,7 +86,7 @@ setFeatureSet features = do def_config = def :: Plugin.Config config = def_config - { Plugin.plugins = M.fromList [("tactics", + { Plugin.plugins = M.fromList [("tactic", def { Plugin.plcConfig = unObject $ object ["features" .= prettyFeatureSet features] } )] <> Plugin.plugins def_config } From 26d1277c35fafb13d3797efbbe6a95f45030af3b Mon Sep 17 00:00:00 2001 From: Potato Hatsue <1793913507@qq.com> Date: Wed, 17 Mar 2021 15:23:51 +0800 Subject: [PATCH 07/13] Revert format changes in tactics plugin --- .../src/Wingman/LanguageServer.hs | 49 ++++++++----------- .../hls-tactics-plugin/src/Wingman/Plugin.hs | 16 +++--- .../hls-tactics-plugin/src/Wingman/Types.hs | 44 ++++++++--------- plugins/hls-tactics-plugin/test/Utils.hs | 28 +++++------ 4 files changed, 61 insertions(+), 76 deletions(-) diff --git a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs index 32652c06e8..5144cf072d 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs @@ -6,46 +6,39 @@ module Wingman.LanguageServer where import ConLike import Control.Arrow import Control.Monad -import Control.Monad.State (State, evalState, get, - put) +import Control.Monad.State (State, get, put, evalState) import Control.Monad.Trans.Maybe import Data.Coerce -import Data.Functor ((<&>)) -import Data.Generics.Aliases (mkQ) -import Data.Generics.Schemes (everything) -import qualified Data.Map as M +import Data.Functor ((<&>)) +import Data.Generics.Aliases (mkQ) +import Data.Generics.Schemes (everything) +import qualified Data.Map as M import Data.Maybe import Data.Monoid -import qualified Data.Set as S -import qualified Data.Text as T +import qualified Data.Set as S +import qualified Data.Text as T import Data.Traversable import Development.IDE.Core.PositionMapping import Development.IDE.Core.RuleTypes -import Development.IDE.Core.Service (runAction) -import Development.IDE.Core.Shake (IdeState (..), - useWithStale) +import Development.IDE.Core.Service (runAction) +import Development.IDE.Core.Shake (IdeState (..), useWithStale) import Development.IDE.GHC.Compat -import Development.IDE.GHC.Error (realSrcSpanToRange) -import Development.IDE.Spans.LocalBindings (Bindings, - getDefiningBindings) -import Development.Shake (Action, RuleResult) -import Development.Shake.Classes (Binary, Hashable, NFData, - Typeable) +import Development.IDE.GHC.Error (realSrcSpanToRange) +import Development.IDE.Spans.LocalBindings (Bindings, getDefiningBindings) +import Development.Shake (Action, RuleResult) +import Development.Shake.Classes (Typeable, Binary, Hashable, NFData) import qualified FastString -import GhcPlugins (consDataCon, - substTyAddInScope, - tupleDataCon) -import qualified Ide.Plugin.Config as Plugin +import GhcPlugins (tupleDataCon, consDataCon, substTyAddInScope) +import Ide.Types (PluginId) +import qualified Ide.Plugin.Config as Plugin +import Ide.PluginUtils (usePropertyLsp) import Ide.Plugin.Properties -import Ide.PluginUtils (usePropertyLsp) -import Ide.Types (PluginId) -import Language.LSP.Server (MonadLsp, - sendNotification) +import Language.LSP.Server (MonadLsp, sendNotification) import Language.LSP.Types import OccName -import Prelude hiding (span) -import SrcLoc (containsSpan) -import TcRnTypes (tcg_binds) +import Prelude hiding (span) +import SrcLoc (containsSpan) +import TcRnTypes (tcg_binds) import Wingman.Context import Wingman.FeatureSet import Wingman.GHC diff --git a/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs b/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs index 3f0fb6bc83..18d5b219c5 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs @@ -7,17 +7,17 @@ module Wingman.Plugin , TacticCommand (..) ) where -import Control.Exception (evaluate) +import Control.Exception (evaluate) import Control.Monad import Control.Monad.Trans import Control.Monad.Trans.Maybe import Data.Aeson -import Data.Bifunctor (first) -import Data.Foldable (for_) +import Data.Bifunctor (first) +import Data.Foldable (for_) import Data.Maybe -import Data.Proxy (Proxy (..)) -import qualified Data.Text as T -import Development.IDE.Core.Shake (IdeState (..)) +import Data.Proxy (Proxy(..)) +import qualified Data.Text as T +import Development.IDE.Core.Shake (IdeState (..)) import Development.IDE.GHC.Compat import Development.IDE.GHC.ExactPrint import Ide.Types @@ -25,13 +25,13 @@ import Language.LSP.Server import Language.LSP.Types import Language.LSP.Types.Capabilities import OccName -import Prelude hiding (span) +import Prelude hiding (span) import System.Timeout import Wingman.CaseSplit import Wingman.GHC import Wingman.LanguageServer import Wingman.LanguageServer.TacticProviders -import Wingman.Machinery (scoreSolution) +import Wingman.Machinery (scoreSolution) import Wingman.Range import Wingman.Tactics import Wingman.Types diff --git a/plugins/hls-tactics-plugin/src/Wingman/Types.hs b/plugins/hls-tactics-plugin/src/Wingman/Types.hs index fd577c4e59..55da1fef6d 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Types.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Types.hs @@ -14,34 +14,30 @@ module Wingman.Types , Range ) where -import ConLike (ConLike) -import Control.Lens hiding (Context, (.=)) +import ConLike (ConLike) +import Control.Lens hiding (Context) import Control.Monad.Reader import Control.Monad.State - import Data.Coerce import Data.Function -import Data.Generics.Product (field) -import Data.List.NonEmpty (NonEmpty (..)) +import Data.Generics.Product (field) +import Data.List.NonEmpty (NonEmpty (..)) import Data.Semigroup -import Data.Set (Set) -import Data.Text (Text) -import qualified Data.Text as T +import Data.Set (Set) +import Data.Text (Text) +import qualified Data.Text as T import Data.Tree -import Development.IDE.GHC.Compat hiding (Node) -import Development.IDE.GHC.Orphans () +import Development.IDE.GHC.Compat hiding (Node) +import Development.IDE.GHC.Orphans () import Development.IDE.Types.Location import GHC.Generics -import GHC.SourceGen (var) +import GHC.SourceGen (var) import OccName import Refinery.Tactic -import System.IO.Unsafe (unsafePerformIO) -import Type (TCvSubst, Var, emptyTCvSubst, - eqType, nonDetCmpType) -import UniqSupply (UniqSupply, mkSplitUniqSupply, - takeUniqFromSupply) -import Unique (Uniquable, Unique, getUnique, - nonDetCmpUnique) +import System.IO.Unsafe (unsafePerformIO) +import Type (TCvSubst, Var, eqType, nonDetCmpType, emptyTCvSubst) +import UniqSupply (takeUniqFromSupply, mkSplitUniqSupply, UniqSupply) +import Unique (nonDetCmpUnique, Uniquable, getUnique, Unique) import Wingman.Debug import Wingman.FeatureSet @@ -141,9 +137,9 @@ instance Show ConLike where -- | The state that should be shared between subgoals. Extracts move towards -- the root, judgments move towards the leaves, and the state moves *sideways*. data TacticState = TacticState - { ts_skolems :: !(Set TyVar) + { ts_skolems :: !(Set TyVar) -- ^ The known skolems. - , ts_unifier :: !TCvSubst + , ts_unifier :: !TCvSubst , ts_unique_gen :: !UniqSupply } deriving stock (Show, Generic) @@ -358,17 +354,17 @@ type Trace = Rose String -- information we'd like to pass from leaves of the tactics search upwards. -- This includes the actual AST we've generated (in 'syn_val'). data Synthesized a = Synthesized - { syn_trace :: Trace + { syn_trace :: Trace -- ^ A tree describing which tactics were used produce the 'syn_val'. -- Mainly for debugging when you get the wrong answer, to see the other -- things it tried. - , syn_scoped :: Hypothesis CType + , syn_scoped :: Hypothesis CType -- ^ All of the bindings created to produce the 'syn_val'. - , syn_used_vals :: Set OccName + , syn_used_vals :: Set OccName -- ^ The values used when synthesizing the 'syn_val'. , syn_recursion_count :: Sum Int -- ^ The number of recursive calls - , syn_val :: a + , syn_val :: a } deriving (Eq, Show, Functor, Foldable, Traversable, Generic) diff --git a/plugins/hls-tactics-plugin/test/Utils.hs b/plugins/hls-tactics-plugin/test/Utils.hs index 37a5d6faf1..1bd0f5eff0 100644 --- a/plugins/hls-tactics-plugin/test/Utils.hs +++ b/plugins/hls-tactics-plugin/test/Utils.hs @@ -8,30 +8,26 @@ module Utils where import Control.Applicative.Combinators (skipManyTill) -import Control.Lens hiding (failing, (.=), (<.>)) -import Control.Monad (unless) +import Control.Lens hiding (failing, (<.>), (.=)) +import Control.Monad (unless) import Control.Monad.IO.Class import Data.Aeson -import Data.Default (Default (def)) +import Data.Default (Default (def)) import Data.Foldable -import qualified Data.Map as M +import qualified Data.Map as M import Data.Maybe -import Data.Text (Text) -import qualified Data.Text.IO as T -import qualified Ide.Plugin.Config as Plugin +import Data.Text (Text) +import qualified Data.Text.IO as T +import qualified Ide.Plugin.Config as Plugin +import Wingman.FeatureSet (FeatureSet, allFeatures, prettyFeatureSet) +import Wingman.LanguageServer (mkShowMessageParams) +import Wingman.Types import Language.LSP.Test import Language.LSP.Types -import Language.LSP.Types.Lens hiding (actions, applyEdit, - capabilities, executeCommand, - id, line, message, name, - rename, title) -import System.Directory (doesFileExist) +import Language.LSP.Types.Lens hiding (actions, applyEdit, capabilities, executeCommand, id, line, message, name, rename, title) +import System.Directory (doesFileExist) import System.FilePath import Test.Hspec -import Wingman.FeatureSet (FeatureSet, allFeatures, - prettyFeatureSet) -import Wingman.LanguageServer (mkShowMessageParams) -import Wingman.Types ------------------------------------------------------------------------------ From 14018f87ff7ea1d46bd3ccfb22012ffa43942dc7 Mon Sep 17 00:00:00 2001 From: Potato Hatsue <1793913507@qq.com> Date: Wed, 17 Mar 2021 15:26:30 +0800 Subject: [PATCH 08/13] Change the descriptor of tactics plugin to "tactics" --- exe/Plugins.hs | 2 +- plugins/hls-tactics-plugin/test/Server.hs | 2 +- plugins/hls-tactics-plugin/test/Utils.hs | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) 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/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 1bd0f5eff0..87c0dcefb1 100644 --- a/plugins/hls-tactics-plugin/test/Utils.hs +++ b/plugins/hls-tactics-plugin/test/Utils.hs @@ -82,7 +82,7 @@ setFeatureSet features = do def_config = def :: Plugin.Config config = def_config - { Plugin.plugins = M.fromList [("tactic", + { Plugin.plugins = M.fromList [("tactics", def { Plugin.plcConfig = unObject $ object ["features" .= prettyFeatureSet features] } )] <> Plugin.plugins def_config } From d626aa8388fbeccf3d00e3b6215eabeee21acc2b Mon Sep 17 00:00:00 2001 From: Potato Hatsue <1793913507@qq.com> Date: Wed, 17 Mar 2021 15:27:30 +0800 Subject: [PATCH 09/13] Update plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs Co-authored-by: Sandy Maguire --- plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs index 5144cf072d..46a22936ff 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs @@ -82,7 +82,7 @@ properties :: Properties PropertyKey "features" 'TString] properties = emptyProperties & defineStringProperty @"features" - "Features set used by wingman (tactic) plugin" "" + "Feature set used by Wingman" "" & defineNumberProperty @"max_use_ctor_actions" "Maximum number of `Use constructor ` code actions that can appear" 5 @@ -364,4 +364,3 @@ mkShowMessageParams ufm = ShowMessageParams (ufmSeverity ufm) $ T.pack $ show uf showLspMessage :: MonadLsp cfg m => ShowMessageParams -> m () showLspMessage = sendNotification SWindowShowMessage - From 0960bb78a2a60094f2f25f9a296fede3254765ae Mon Sep 17 00:00:00 2001 From: Potato Hatsue <1793913507@qq.com> Date: Thu, 18 Mar 2021 17:26:37 +0800 Subject: [PATCH 10/13] Apply a bunch of @isovector's suggestions --- .../src/Development/IDE/Plugin/TypeLenses.hs | 12 +- hls-plugin-api/src/Ide/Plugin/Properties.hs | 304 +++++++++++------- hls-plugin-api/src/Ide/PluginUtils.hs | 15 +- .../src/Wingman/LanguageServer.hs | 13 +- 4 files changed, 204 insertions(+), 140 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index 085f97cffc..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 ( @@ -90,9 +91,9 @@ descriptor plId = , pluginCustomConfig = mkCustomConfig properties } -properties :: Properties '[PropertyKey "mode" 'TEnum] +properties :: Properties '[ 'PropertyKey "mode" 'TEnum] properties = emptyProperties - & defineEnumProperty @"mode" "Control how type lenses are shown" + & 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") @@ -104,7 +105,7 @@ codeLensProvider :: CodeLensParams -> LSP.LspM Config (Either ResponseError (List CodeLens)) codeLensProvider ideState pId CodeLensParams{_textDocument = TextDocumentIdentifier uri} = do - mode <- readMode <$> usePropertyLsp @"mode" pId properties + 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) @@ -249,6 +250,7 @@ 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) diff --git a/hls-plugin-api/src/Ide/Plugin/Properties.hs b/hls-plugin-api/src/Ide/Plugin/Properties.hs index 206255aa22..4640709fda 100644 --- a/hls-plugin-api/src/Ide/Plugin/Properties.hs +++ b/hls-plugin-api/src/Ide/Plugin/Properties.hs @@ -1,17 +1,19 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# 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 #-} @@ -19,8 +21,9 @@ module Ide.Plugin.Properties ( PropertyType (..), ToHsType, MetaData (..), - PropertyKey, + PropertyKey (..), SPropertyKey (..), + KeyNameProxy (..), Properties, HasProperty, emptyProperties, @@ -38,19 +41,18 @@ module Ide.Plugin.Properties ) 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 Data.Proxy (Proxy (..)) -import qualified Data.Text as T +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) - --- --------------------------------------------------------------------- +import Unsafe.Coerce (unsafeCoerce) +-- | Types properties may have data PropertyType = TNumber | TString @@ -69,87 +71,118 @@ type family ToHsType (t :: PropertyType) where -- --------------------------------------------------------------------- +-- | Metadata of a property data MetaData (t :: PropertyType) where MetaData :: - (IsNotTEnum t) => - {defaultValue :: ToHsType t, description :: T.Text} -> + (IsTEnum t ~ 'False) => + { defaultValue :: ToHsType t, + description :: T.Text + } -> MetaData t EnumMetaData :: - (IsTEnum t) => + (IsTEnum t ~ 'True) => { defaultValue :: ToHsType t, description :: T.Text, - enumValues :: [T.Text], + enumValues :: [ToHsType t], enumDescriptions :: [T.Text] } -> MetaData t -data PropertyKey (s :: Symbol) (t :: PropertyType) +-- | Used at type level for name-type mapping in 'Properties' +data PropertyKey = PropertyKey Symbol PropertyType -data SPropertyKey k where - SNumber :: SPropertyKey (PropertyKey s 'TNumber) - 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) +-- | Singleton type of 'PropertyKey' +data SPropertyKey (k :: PropertyKey) where + SNumber :: SPropertyKey ('PropertyKey s 'TNumber) + 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) + (k ~ 'PropertyKey s t) => + SomePropertyKeyWithMetaData (SPropertyKey k) (MetaData t) --- | Describes dedicated configuration of a plugin. --- --- It was designed to be compatible with vscode's poor settings UI -newtype Properties (r :: [*]) = Properties (Map.Map String SomePropertyKeyWithMetaData) +-- | 'Properties' 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 -type family IsTEnum (t :: PropertyType) :: Constraint where - IsTEnum 'TEnum = () - IsTEnum x = TypeError ('Text "Expected ‘" ':<>: 'ShowType 'TEnum ':<>: 'Text "’, but got ‘" ':<>: 'ShowType x ':<>: 'Text "’") +instance (KnownSymbol s', s ~ s') => IsLabel s (KeyNameProxy s') where + fromLabel = KeyNameProxy + +-- --------------------------------------------------------------------- -type family IsNotTEnum (t :: PropertyType) :: Constraint where - IsNotTEnum 'TEnum = TypeError ('Text "Unexpected " ':<>: 'ShowType 'TEnum) - IsNotTEnum x = () +type family IsTEnum (t :: PropertyType) :: Bool where + IsTEnum 'TEnum = 'True + IsTEnum _ = 'False -type family FindKey (s :: Symbol) r where - FindKey s (PropertyKey s t ': _) = t - FindKey s (_ ': xs) = FindKey s xs +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 :: Constraint where - Elem s (PropertyKey s _ ': _) = () +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 undefined") + Elem s '[] = TypeError ('Text "The key ‘" ':<>: 'Text s ':<>: 'Text "’ is missing") -type family NotElem (s :: Symbol) r :: Constraint where - NotElem s (PropertyKey s _ ': _) = TypeError ('Text "The key ‘" ':<>: 'Text s ':<>: 'Text "’ is already defined") +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 '[] = () -type HasProperty s k t r = (k ~ PropertyKey s t, Elem s r, FindKey s r ~ t, KnownSymbol 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 :: - forall s k r t. - (k ~ PropertyKey s t, NotElem s r, KnownSymbol s) => + (k ~ 'PropertyKey s t, NotElem s r, KnownSymbol s) => + KeyNameProxy s -> SPropertyKey k -> MetaData t -> Properties r -> Properties (k ': r) -insert key metadata (Properties old) = Properties (Map.insert (symbolVal (Proxy @s)) (SomePropertyKeyWithMetaData (key, metadata)) old) +insert kn key metadata (Properties old) = + Properties + ( Map.insert + (symbolVal kn) + (SomePropertyKeyWithMetaData key metadata) + old + ) find :: - forall s k r t. (HasProperty s k t r) => + KeyNameProxy s -> Properties r -> (SPropertyKey k, MetaData t) -find (Properties p) = case p Map.! symbolVal (Proxy @s) of - (SomePropertyKeyWithMetaData x) -> +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, @@ -158,37 +191,40 @@ find (Properties p) = case p Map.! symbolVal (Proxy @s) of -- 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 x + unsafeCoerce (sing, metadata) -- --------------------------------------------------------------------- -- | Given the name of a defined property, generates a JSON parser of 'plcConfig' usePropertyEither :: - forall s k t r. (HasProperty s k t r) => + KeyNameProxy s -> Properties r -> A.Object -> Either String (ToHsType t) -usePropertyEither p = parseProperty @s (find p) +usePropertyEither k p = parseProperty k (find k p) -- | Like 'usePropertyEither' but returns 'defaultValue' on parse error useProperty :: - forall s k t r. (HasProperty s k t r) => + KeyNameProxy s -> Properties r -> Maybe A.Object -> ToHsType t -useProperty p = maybe (defaultValue metadata) (fromRight (defaultValue metadata) . usePropertyEither @s p) +useProperty k p = + maybe + (defaultValue metadata) + (fromRight (defaultValue metadata) . usePropertyEither k p) where - (_, metadata) = find @s p + (_, metadata) = find k p parseProperty :: - forall s k t. - (k ~ PropertyKey s t, KnownSymbol s) => + (k ~ 'PropertyKey s t, KnownSymbol s) => + KeyNameProxy s -> (SPropertyKey k, MetaData t) -> A.Object -> Either String (ToHsType t) -parseProperty km x = case km of +parseProperty k km x = case km of (SNumber, _) -> parseEither (SString, _) -> parseEither (SBoolean, _) -> parseEither @@ -200,136 +236,165 @@ parseProperty km x = case km of txt <- o A..: keyName if txt `elem` enumValues then pure txt - else fail $ "unknown enum option: " <> T.unpack txt + else + fail $ + "invalid enum member: " + <> T.unpack txt + <> ". Expected one of " + <> show enumValues ) x - _ -> error "impossible" where - keyName = T.pack $ symbolVal (Proxy @s) + keyName = T.pack $ symbolVal k parseEither :: forall a. A.FromJSON a => Either String a parseEither = A.parseEither (A..: keyName) x -- --------------------------------------------------------------------- +-- | Defines a number property defineNumberProperty :: - forall s r. (KnownSymbol s, NotElem s r) => + KeyNameProxy s -> + -- | description T.Text -> + -- | default value Int -> Properties r -> - Properties (PropertyKey s 'TNumber : r) -defineNumberProperty description defaultValue = insert SNumber MetaData {..} + Properties ('PropertyKey s 'TNumber : r) +defineNumberProperty kn description defaultValue = + insert kn SNumber MetaData {..} +-- | Defines a string property defineStringProperty :: - forall s r. (KnownSymbol s, NotElem s r) => + KeyNameProxy s -> + -- | description T.Text -> + -- | default value T.Text -> Properties r -> - Properties (PropertyKey s 'TString : r) -defineStringProperty description defaultValue = insert SString MetaData {..} + Properties ('PropertyKey s 'TString : r) +defineStringProperty kn description defaultValue = + insert kn SString MetaData {..} +-- | Defines a boolean property defineBooleanProperty :: - forall s r. (KnownSymbol s, NotElem s r) => + KeyNameProxy s -> + -- | description T.Text -> + -- | default value Bool -> Properties r -> - Properties (PropertyKey s 'TBoolean : r) -defineBooleanProperty description defaultValue = insert SBoolean MetaData {..} + 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 description defaultValue = insert SObject MetaData {..} + Properties ('PropertyKey s 'TObject : r) +defineObjectProperty kn description defaultValue = + insert kn SObject MetaData {..} +-- | Defines an array property defineArrayProperty :: - forall s r. (KnownSymbol s, NotElem s r) => + KeyNameProxy s -> + -- | description T.Text -> + -- | default value A.Array -> Properties r -> - Properties (PropertyKey s 'TArray : r) -defineArrayProperty description defaultValue = insert SArray MetaData {..} + Properties ('PropertyKey s 'TArray : r) +defineArrayProperty kn description defaultValue = + insert kn SArray MetaData {..} +-- | Defines an enum property defineEnumProperty :: - forall s r. (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 description enums defaultValue = insert SEnum $ EnumMetaData defaultValue description (fst <$> enums) (snd <$> enums) + 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 k v | (k, v) <- Map.toList p] +toDefaultJSON (Properties p) = [toEntry s v | (s, v) <- Map.toList p] where toEntry :: String -> SomePropertyKeyWithMetaData -> A.Pair - toEntry s (SomePropertyKeyWithMetaData k) = case k of - (SNumber, MetaData {..}) -> - T.pack s A..= defaultValue - (SString, MetaData {..}) -> - T.pack s A..= defaultValue - (SBoolean, MetaData {..}) -> - T.pack s A..= defaultValue - (SObject, MetaData {..}) -> - T.pack s A..= defaultValue - (SArray, MetaData {..}) -> - T.pack s A..= defaultValue - (SEnum, EnumMetaData {..}) -> - T.pack s A..= defaultValue - _ -> error "impossible" - + toEntry (T.pack -> s) = \case + (SomePropertyKeyWithMetaData SNumber 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 (SomePropertyKeyWithMetaData k) = case k of - (SNumber, MetaData {..}) -> + toEntry = \case + (SomePropertyKeyWithMetaData SNumber MetaData {..}) -> A.object [ "type" A..= A.String "number", "markdownDescription" A..= description, "default" A..= defaultValue, "scope" A..= A.String "resource" ] - (SString, MetaData {..}) -> + (SomePropertyKeyWithMetaData SString MetaData {..}) -> A.object [ "type" A..= A.String "string", "markdownDescription" A..= description, "default" A..= defaultValue, "scope" A..= A.String "resource" ] - (SBoolean, MetaData {..}) -> + (SomePropertyKeyWithMetaData SBoolean MetaData {..}) -> A.object [ "type" A..= A.String "boolean", "markdownDescription" A..= description, "default" A..= defaultValue, "scope" A..= A.String "resource" ] - (SObject, MetaData {..}) -> + (SomePropertyKeyWithMetaData SObject MetaData {..}) -> A.object [ "type" A..= A.String "object", "markdownDescription" A..= description, "default" A..= defaultValue, "scope" A..= A.String "resource" ] - (SArray, MetaData {..}) -> + (SomePropertyKeyWithMetaData SArray MetaData {..}) -> A.object [ "type" A..= A.String "array", "markdownDescription" A..= description, "default" A..= defaultValue, "scope" A..= A.String "resource" ] - (SEnum, EnumMetaData {..}) -> + (SomePropertyKeyWithMetaData SEnum EnumMetaData {..}) -> A.object [ "type" A..= A.String "string", "description" A..= description, @@ -338,4 +403,3 @@ toVSCodeExtensionSchema prefix (Properties p) = "default" A..= defaultValue, "scope" A..= A.String "resource" ] - _ -> error "impossible" diff --git a/hls-plugin-api/src/Ide/PluginUtils.hs b/hls-plugin-api/src/Ide/PluginUtils.hs index 600175e434..d0ae8d8132 100644 --- a/hls-plugin-api/src/Ide/PluginUtils.hs +++ b/hls-plugin-api/src/Ide/PluginUtils.hs @@ -1,9 +1,6 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} module Ide.PluginUtils ( WithDeletions(..), getProcessID, @@ -172,14 +169,14 @@ getPluginConfig plugin = do -- | Returns the value of a property defined by the current plugin. usePropertyLsp :: - forall s k t r m. (HasProperty s k t r, MonadLsp Config m) => + KeyNameProxy s -> PluginId -> Properties r -> m (ToHsType t) -usePropertyLsp pId p = do +usePropertyLsp kn pId p = do config <- getPluginConfig pId - return $ useProperty @s p $ plcConfig <$> config + return $ useProperty kn p $ plcConfig <$> config -- --------------------------------------------------------------------- diff --git a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs index 46a22936ff..bdb13340f4 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs @@ -78,12 +78,13 @@ runStaleIde state nfp a = MaybeT $ runIde state $ useWithStale a nfp ------------------------------------------------------------------------------ properties :: Properties - '[PropertyKey "max_use_ctor_actions" 'TNumber, - PropertyKey "features" 'TString] + '[ 'PropertyKey + "max_use_ctor_actions" 'TNumber, + 'PropertyKey "features" 'TString] properties = emptyProperties - & defineStringProperty @"features" + & defineStringProperty #features "Feature set used by Wingman" "" - & defineNumberProperty @"max_use_ctor_actions" + & defineNumberProperty #max_use_ctor_actions "Maximum number of `Use constructor ` code actions that can appear" 5 @@ -91,8 +92,8 @@ properties = emptyProperties getTacticConfig :: MonadLsp Plugin.Config m => PluginId -> m Config getTacticConfig pId = Config - <$> (parseFeatureSet <$> usePropertyLsp @"features" pId properties) - <*> usePropertyLsp @"max_use_ctor_actions" pId properties + <$> (parseFeatureSet <$> usePropertyLsp #features pId properties) + <*> usePropertyLsp #max_use_ctor_actions pId properties ------------------------------------------------------------------------------ -- | Get the current feature set from the plugin config. From 03088ee5714fa494d023d78554c985c636a7bd5b Mon Sep 17 00:00:00 2001 From: Potato Hatsue <1793913507@qq.com> Date: Thu, 18 Mar 2021 22:55:01 +0800 Subject: [PATCH 11/13] Document Ide.Plugin.ConfigUtils --- hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs | 47 ++++++++++++++++++-- 1 file changed, 43 insertions(+), 4 deletions(-) diff --git a/hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs b/hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs index e32d6c35bb..fad0fe7ed9 100644 --- a/hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs +++ b/hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs @@ -17,12 +17,18 @@ 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 + A.Object $ HMap.insert "plugin" elems o -- inplace the "plugin" section with our 'elems', leaving others unchanged ) "haskell" (unsafeValueToObject (A.toJSON defaultConfig)) @@ -31,25 +37,56 @@ pluginsToDefaultConfig IdePlugins {..} = 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 = geenericDefaultConfig <> dedicatedDefaultConfig + 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 redundant configuration for formatters: + -- which avoids producing trivial configuration for formatters: -- -- "stylish-haskell": { -- "globalOn": true -- } - geenericDefaultConfig = + 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] @@ -60,6 +97,8 @@ pluginsToDefaultConfig IdePlugins {..} = 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 From 0bda5272a84f376e46e2ffc0d301f4051365d578 Mon Sep 17 00:00:00 2001 From: Potato Hatsue <1793913507@qq.com> Date: Fri, 19 Mar 2021 11:46:08 +0800 Subject: [PATCH 12/13] Add TInteger --- hls-plugin-api/src/Ide/Plugin/Properties.hs | 46 +++++++++++++++---- .../src/Wingman/LanguageServer.hs | 5 +- 2 files changed, 39 insertions(+), 12 deletions(-) diff --git a/hls-plugin-api/src/Ide/Plugin/Properties.hs b/hls-plugin-api/src/Ide/Plugin/Properties.hs index 4640709fda..4ed10cb2c1 100644 --- a/hls-plugin-api/src/Ide/Plugin/Properties.hs +++ b/hls-plugin-api/src/Ide/Plugin/Properties.hs @@ -28,6 +28,7 @@ module Ide.Plugin.Properties HasProperty, emptyProperties, defineNumberProperty, + defineIntegerProperty, defineStringProperty, defineBooleanProperty, defineObjectProperty, @@ -55,6 +56,7 @@ import Unsafe.Coerce (unsafeCoerce) -- | Types properties may have data PropertyType = TNumber + | TInteger | TString | TBoolean | TObject @@ -62,7 +64,8 @@ data PropertyType | TEnum type family ToHsType (t :: PropertyType) where - ToHsType 'TNumber = Int + 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 @@ -94,6 +97,7 @@ 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) @@ -106,7 +110,8 @@ data SomePropertyKeyWithMetaData (k ~ 'PropertyKey s t) => SomePropertyKeyWithMetaData (SPropertyKey k) (MetaData t) --- | 'Properties' defines a set of properties which used in dedicated configuration of a plugin. +-- | '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'. @@ -202,7 +207,7 @@ usePropertyEither :: Properties r -> A.Object -> Either String (ToHsType t) -usePropertyEither k p = parseProperty k (find k p) +usePropertyEither kn p = parseProperty kn (find k p) -- | Like 'usePropertyEither' but returns 'defaultValue' on parse error useProperty :: @@ -211,12 +216,12 @@ useProperty :: Properties r -> Maybe A.Object -> ToHsType t -useProperty k p = +useProperty kn p = maybe (defaultValue metadata) - (fromRight (defaultValue metadata) . usePropertyEither k p) + (fromRight (defaultValue metadata) . usePropertyEither kn p) where - (_, metadata) = find k p + (_, metadata) = find kn p parseProperty :: (k ~ 'PropertyKey s t, KnownSymbol s) => @@ -224,8 +229,9 @@ parseProperty :: (SPropertyKey k, MetaData t) -> A.Object -> Either String (ToHsType t) -parseProperty k km x = case km of +parseProperty kn k x = case k of (SNumber, _) -> parseEither + (SInteger, _) -> parseEither (SString, _) -> parseEither (SBoolean, _) -> parseEither (SObject, _) -> parseEither @@ -245,7 +251,7 @@ parseProperty k km x = case km of ) x where - keyName = T.pack $ symbolVal k + keyName = T.pack $ symbolVal kn parseEither :: forall a. A.FromJSON a => Either String a parseEither = A.parseEither (A..: keyName) x @@ -258,12 +264,25 @@ defineNumberProperty :: -- | description T.Text -> -- | default value - Int -> + 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) => @@ -341,6 +360,8 @@ toDefaultJSON (Properties p) = [toEntry s v | (s, v) <- Map.toList p] 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 {..}) -> @@ -366,6 +387,13 @@ toVSCodeExtensionSchema prefix (Properties p) = "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", diff --git a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs index bdb13340f4..417cc0e4ea 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs @@ -78,13 +78,12 @@ runStaleIde state nfp a = MaybeT $ runIde state $ useWithStale a nfp ------------------------------------------------------------------------------ properties :: Properties - '[ 'PropertyKey - "max_use_ctor_actions" 'TNumber, + '[ 'PropertyKey "max_use_ctor_actions" 'TInteger, 'PropertyKey "features" 'TString] properties = emptyProperties & defineStringProperty #features "Feature set used by Wingman" "" - & defineNumberProperty #max_use_ctor_actions + & defineIntegerProperty #max_use_ctor_actions "Maximum number of `Use constructor ` code actions that can appear" 5 From f79bd34a04f75823385226b7e7471930b325ee98 Mon Sep 17 00:00:00 2001 From: Potato Hatsue <1793913507@qq.com> Date: Fri, 19 Mar 2021 12:19:45 +0800 Subject: [PATCH 13/13] Fix build --- hls-plugin-api/src/Ide/Plugin/Properties.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hls-plugin-api/src/Ide/Plugin/Properties.hs b/hls-plugin-api/src/Ide/Plugin/Properties.hs index 4ed10cb2c1..ba2edb5f49 100644 --- a/hls-plugin-api/src/Ide/Plugin/Properties.hs +++ b/hls-plugin-api/src/Ide/Plugin/Properties.hs @@ -207,7 +207,7 @@ usePropertyEither :: Properties r -> A.Object -> Either String (ToHsType t) -usePropertyEither kn p = parseProperty kn (find k p) +usePropertyEither kn p = parseProperty kn (find kn p) -- | Like 'usePropertyEither' but returns 'defaultValue' on parse error useProperty ::