From e71911dc6520e425e1d676d37e37657245b79a5a Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Mon, 28 Dec 2020 20:23:08 +0000 Subject: [PATCH 01/10] Invert the dependency between ghcide and hls-plugin-api This PR includes changes both to ghcide and HLS to implement the reorg described in https://github.com/haskell/ghcide/issues/936#issuecomment-751437853 To summarise: - `hls-plugin-api` no longer depends on ghcide. - `ghcide` now depends on `hls-plugin-api` and exposes: - The ghcide HLS plugin - The `asGhcIdePlugin` adaptor The goals are: - to be able to break the `ghcide` HLS plugin down - to rewrite exe:ghcide on top of the HLS plugin model. The ghcide side is reviewed in https://github.com/haskell/ghcide/pull/963 If this change is accepted there are two further considerations: - This would be a good moment to merge the 2 repos, so that there is no history loss. - `hls-plugin-api` will need to be released to Hackage prior to merging https://github.com/haskell/ghcide/pull/963 --- exe/Plugins.hs | 7 +- ghcide/ghcide.cabal | 6 +- ghcide/src/Development/IDE.hs | 1 + ghcide/src/Development/IDE/Compat.hs | 19 --- .../Development/IDE/Core/IdeConfiguration.hs | 2 +- ghcide/src/Development/IDE/Core/Rules.hs | 12 ++ ghcide/src/Development/IDE/Plugin.hs | 23 ++- .../src/Development/IDE/Plugin/HLS.hs | 145 ++++------------ .../Development/IDE/Plugin/HLS}/Formatter.hs | 45 +---- .../src/Development/IDE/Plugin/HLS}/GhcIde.hs | 18 +- hls-plugin-api/hls-plugin-api.cabal | 13 +- hls-plugin-api/src/Ide/Logger.hs | 16 +- hls-plugin-api/src/Ide/PluginUtils.hs | 159 +++++++++++++++++- hls-plugin-api/src/Ide/Types.hs | 68 ++++---- plugins/default/src/Ide/Plugin/Brittany.hs | 6 +- plugins/default/src/Ide/Plugin/Example.hs | 14 +- plugins/default/src/Ide/Plugin/Example2.hs | 14 +- plugins/default/src/Ide/Plugin/Floskell.hs | 6 +- plugins/default/src/Ide/Plugin/Fourmolu.hs | 7 +- plugins/default/src/Ide/Plugin/ModuleName.hs | 11 +- plugins/default/src/Ide/Plugin/Ormolu.hs | 5 +- plugins/default/src/Ide/Plugin/Pragmas.hs | 7 +- .../default/src/Ide/Plugin/StylishHaskell.hs | 6 +- .../hls-class-plugin/src/Ide/Plugin/Class.hs | 9 +- .../hls-eval-plugin/src/Ide/Plugin/Eval.hs | 3 +- .../src/Ide/Plugin/Eval/CodeLens.hs | 8 +- .../src/Ide/Plugin/ExplicitImports.hs | 12 +- .../hls-hlint-plugin/src/Ide/Plugin/Hlint.hs | 9 +- .../src/Ide/Plugin/Retrie.hs | 8 +- plugins/tactics/src/Ide/Plugin/Tactic.hs | 8 +- src/Ide/Main.hs | 26 ++- 31 files changed, 361 insertions(+), 332 deletions(-) delete mode 100644 ghcide/src/Development/IDE/Compat.hs rename hls-plugin-api/src/Ide/Plugin.hs => ghcide/src/Development/IDE/Plugin/HLS.hs (83%) rename {hls-plugin-api/src/Ide/Plugin => ghcide/src/Development/IDE/Plugin/HLS}/Formatter.hs (67%) rename {hls-plugin-api/src/Ide/Plugin => ghcide/src/Development/IDE/Plugin/HLS}/GhcIde.hs (84%) diff --git a/exe/Plugins.hs b/exe/Plugins.hs index 83c3899daa..1bd2336e9c 100644 --- a/exe/Plugins.hs +++ b/exe/Plugins.hs @@ -3,12 +3,13 @@ module Plugins where import Ide.Types (IdePlugins) -import Ide.Plugin (pluginDescToIdePlugins) +import Ide.PluginUtils (pluginDescToIdePlugins) -- fixed plugins import Ide.Plugin.Example as Example import Ide.Plugin.Example2 as Example2 -import Ide.Plugin.GhcIde as GhcIde +import Development.IDE (IdeState) +import Development.IDE.Plugin.HLS.GhcIde as GhcIde -- haskell-language-server optional plugins @@ -73,7 +74,7 @@ import Ide.Plugin.Brittany as Brittany -- These can be freely added or removed to tailor the available -- features of the server. -idePlugins :: Bool -> IdePlugins +idePlugins :: Bool -> IdePlugins IdeState idePlugins includeExamples = pluginDescToIdePlugins allPlugins where allPlugins = if includeExamples diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index b0d99e7188..7ea4e01df0 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -56,6 +56,8 @@ library haskell-lsp-types == 0.22.*, haskell-lsp == 0.22.*, hie-compat, + hls-plugin-api, + lens, mtl, network-uri, parallel, @@ -127,7 +129,6 @@ library include exposed-modules: Development.IDE - Development.IDE.Compat Development.IDE.Core.Debouncer Development.IDE.Core.FileStore Development.IDE.Core.IdeConfiguration @@ -163,6 +164,8 @@ library Development.IDE.Plugin Development.IDE.Plugin.Completions Development.IDE.Plugin.CodeAction + Development.IDE.Plugin.HLS + Development.IDE.Plugin.HLS.GhcIde Development.IDE.Plugin.Test -- Unfortunately, we cannot use loadSession with ghc-lib since hie-bios uses @@ -190,6 +193,7 @@ library Development.IDE.Plugin.CodeAction.RuleTypes Development.IDE.Plugin.Completions.Logic Development.IDE.Plugin.Completions.Types + Development.IDE.Plugin.HLS.Formatter Development.IDE.Types.Action ghc-options: -Wall -Wno-name-shadowing -Wincomplete-uni-patterns diff --git a/ghcide/src/Development/IDE.hs b/ghcide/src/Development/IDE.hs index 59da23941a..b0b5ede546 100644 --- a/ghcide/src/Development/IDE.hs +++ b/ghcide/src/Development/IDE.hs @@ -9,6 +9,7 @@ module Development.IDE import Development.IDE.Core.RuleTypes as X import Development.IDE.Core.Rules as X (getAtPoint + ,getClientConfigAction ,getDefinition ,getParsedModule ,getTypeDefinition diff --git a/ghcide/src/Development/IDE/Compat.hs b/ghcide/src/Development/IDE/Compat.hs deleted file mode 100644 index 30c8b7d88c..0000000000 --- a/ghcide/src/Development/IDE/Compat.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE CPP #-} -module Development.IDE.Compat - ( - getProcessID - ) where - -#ifdef mingw32_HOST_OS - -import qualified System.Win32.Process as P (getCurrentProcessId) -getProcessID :: IO Int -getProcessID = fromIntegral <$> P.getCurrentProcessId - -#else - -import qualified System.Posix.Process as P (getProcessID) -getProcessID :: IO Int -getProcessID = fromIntegral <$> P.getProcessID - -#endif diff --git a/ghcide/src/Development/IDE/Core/IdeConfiguration.hs b/ghcide/src/Development/IDE/Core/IdeConfiguration.hs index d42322556d..a9bfe088a1 100644 --- a/ghcide/src/Development/IDE/Core/IdeConfiguration.hs +++ b/ghcide/src/Development/IDE/Core/IdeConfiguration.hs @@ -88,4 +88,4 @@ isWorkspaceFile file = workspaceFolders getClientSettings :: Action (Maybe Value) -getClientSettings = unhashed . clientSettings <$> getIdeConfiguration \ No newline at end of file +getClientSettings = unhashed . clientSettings <$> getIdeConfiguration diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 9ad5a705cf..862379894f 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -27,11 +27,14 @@ module Development.IDE.Core.Rules( highlightAtPoint, getDependencies, getParsedModule, + getClientConfigAction, ) where import Fingerprint +import Data.Aeson (fromJSON, Result(Success), FromJSON) import Data.Binary hiding (get, put) +import Data.Default import Data.Tuple.Extra import Control.Monad.Extra import Control.Monad.Trans.Class @@ -890,6 +893,15 @@ getClientSettingsRule = defineEarlyCutOffNoFile $ \GetClientSettings -> do settings <- clientSettings <$> getIdeConfiguration return (BS.pack . show . hash $ settings, settings) +-- | Returns the client configurarion stored in the IdeState. +-- You can use this function to access it from shake Rules +getClientConfigAction :: (Default a, FromJSON a) => Action a +getClientConfigAction = do + mbVal <- unhashed <$> useNoFile_ GetClientSettings + case fromJSON <$> mbVal of + Just (Success c) -> return c + _ -> return def + -- | For now we always use bytecode getLinkableType :: NormalizedFilePath -> Action (Maybe LinkableType) getLinkableType f = do diff --git a/ghcide/src/Development/IDE/Plugin.hs b/ghcide/src/Development/IDE/Plugin.hs index e232e3f20c..a7094ac15e 100644 --- a/ghcide/src/Development/IDE/Plugin.hs +++ b/ghcide/src/Development/IDE/Plugin.hs @@ -1,14 +1,17 @@ - -module Development.IDE.Plugin(Plugin(..), codeActionPlugin, codeActionPluginWithRules,makeLspCommandId,getPid) where +module Development.IDE.Plugin + ( Plugin(..) + , codeActionPlugin + , codeActionPluginWithRules + , makeLspCommandId + ) where import Data.Default import qualified Data.Text as T import Development.Shake import Development.IDE.LSP.Server - -import Language.Haskell.LSP.Types -import Development.IDE.Compat import Development.IDE.Core.Rules +import Ide.PluginUtils +import Language.Haskell.LSP.Types import qualified Language.Haskell.LSP.Core as LSP import Language.Haskell.LSP.Messages @@ -50,11 +53,5 @@ codeActionPluginWithRules rr f = Plugin rr $ PartialHandlers $ \WithMessage{..} -- on that. makeLspCommandId :: T.Text -> IO T.Text makeLspCommandId command = do - pid <- getPid - return $ pid <> ":ghcide:" <> command - --- | Get the operating system process id for the running server --- instance. This should be the same for the lifetime of the instance, --- and different from that of any other currently running instance. -getPid :: IO T.Text -getPid = T.pack . show <$> getProcessID + pid <- getProcessID + return $ T.pack (show pid) <> ":ghcide:" <> command diff --git a/hls-plugin-api/src/Ide/Plugin.hs b/ghcide/src/Development/IDE/Plugin/HLS.hs similarity index 83% rename from hls-plugin-api/src/Ide/Plugin.hs rename to ghcide/src/Development/IDE/Plugin/HLS.hs index 7913c54778..d1990ebdae 100644 --- a/hls-plugin-api/src/Ide/Plugin.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS.hs @@ -7,41 +7,27 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -module Ide.Plugin +module Development.IDE.Plugin.HLS ( asGhcIdePlugin - , pluginDescToIdePlugins - , mkLspCommand - , mkLspCmdId - , allLspCmdIds - , allLspCmdIds' - , getPid - , responseError - , getClientConfig - , getClientConfigAction - , getPluginConfig - , configForPlugin - , pluginEnabled ) where import Control.Exception(SomeException, catch) import Control.Lens ( (^.) ) import Control.Monad import qualified Data.Aeson as J -import qualified Data.Default import Data.Either -import Data.Hashable (unhashed) import qualified Data.List as List import qualified Data.Map as Map import Data.Maybe import qualified Data.Text as T -import Development.IDE hiding (pluginRules) +import Development.IDE.Core.Shake import Development.IDE.LSP.Server +import Development.IDE.Plugin +import Development.IDE.Plugin.HLS.Formatter import GHC.Generics -import Ide.Logger import Ide.Plugin.Config -import Ide.Plugin.Formatter -import Ide.Types +import Ide.Types as HLS import qualified Language.Haskell.LSP.Core as LSP import Language.Haskell.LSP.Messages import Language.Haskell.LSP.Types @@ -50,15 +36,18 @@ import qualified Language.Haskell.LSP.Types.Capabilities as C import Language.Haskell.LSP.Types.Lens as L hiding (formatting, rangeFormatting) import qualified Language.Haskell.LSP.VFS as VFS import Text.Regex.TDFA.Text() +import Development.Shake (Rules) +import Ide.PluginUtils (getClientConfig, pluginEnabled, getPluginConfig, responseError, getProcessID) +import Development.IDE.Types.Logger (logInfo) -- --------------------------------------------------------------------- -- | Map a set of plugins to the underlying ghcide engine. Main point is -- IdePlugins are arranged by kind of operation, 'Plugin' is arranged by message -- category ('Notifaction', 'Request' etc). -asGhcIdePlugin :: IdePlugins -> Plugin Config +asGhcIdePlugin :: IdePlugins IdeState -> Plugin Config asGhcIdePlugin mp = - mkPlugin rulesPlugins (Just . pluginRules) <> + mkPlugin rulesPlugins (Just . HLS.pluginRules) <> mkPlugin executeCommandPlugins (Just . pluginCommands) <> mkPlugin codeActionPlugins pluginCodeActionProvider <> mkPlugin codeLensPlugins pluginCodeLensProvider <> @@ -74,7 +63,7 @@ asGhcIdePlugin mp = ls = Map.toList (ipMap mp) - mkPlugin :: ([(PluginId, b)] -> Plugin Config) -> (PluginDescriptor -> Maybe b) -> Plugin Config + mkPlugin :: ([(PluginId, b)] -> Plugin Config) -> (PluginDescriptor IdeState -> Maybe b) -> Plugin Config mkPlugin maker selector = case concatMap (\(pid, p) -> justs (pid, selector p)) ls of -- If there are no plugins that provide a descriptor, use mempty to @@ -83,21 +72,6 @@ asGhcIdePlugin mp = [] -> mempty xs -> maker xs - -pluginDescToIdePlugins :: [PluginDescriptor] -> IdePlugins -pluginDescToIdePlugins plugins = IdePlugins $ Map.fromList $ map (\p -> (pluginId p, p)) plugins - -allLspCmdIds' :: T.Text -> IdePlugins -> [T.Text] -allLspCmdIds' pid mp = mkPlugin (allLspCmdIds pid) (Just . pluginCommands) - where - justs (p, Just x) = [(p, x)] - justs (_, Nothing) = [] - - ls = Map.toList (ipMap mp) - - mkPlugin maker selector - = maker $ concatMap (\(pid, p) -> justs (pid, selector p)) ls - -- --------------------------------------------------------------------- rulesPlugins :: [(PluginId, Rules ())] -> Plugin Config @@ -105,19 +79,19 @@ rulesPlugins rs = Plugin rules mempty where rules = mconcat $ map snd rs -codeActionPlugins :: [(PluginId, CodeActionProvider)] -> Plugin Config +codeActionPlugins :: [(PluginId, CodeActionProvider IdeState)] -> Plugin Config codeActionPlugins cas = Plugin codeActionRules (codeActionHandlers cas) codeActionRules :: Rules () codeActionRules = mempty -codeActionHandlers :: [(PluginId, CodeActionProvider)] -> PartialHandlers Config +codeActionHandlers :: [(PluginId, CodeActionProvider IdeState)] -> PartialHandlers Config codeActionHandlers cas = PartialHandlers $ \WithMessage{..} x -> return x { LSP.codeActionHandler = withResponse RspCodeAction (makeCodeAction cas) } -makeCodeAction :: [(PluginId, CodeActionProvider)] +makeCodeAction :: [(PluginId, CodeActionProvider IdeState)] -> LSP.LspFuncs Config -> IdeState -> CodeActionParams -> IO (Either ResponseError (List CAResult)) @@ -168,19 +142,19 @@ data FallbackCodeActionParams = -- ----------------------------------------------------------- -codeLensPlugins :: [(PluginId, CodeLensProvider)] -> Plugin Config +codeLensPlugins :: [(PluginId, CodeLensProvider IdeState)] -> Plugin Config codeLensPlugins cas = Plugin codeLensRules (codeLensHandlers cas) codeLensRules :: Rules () codeLensRules = mempty -codeLensHandlers :: [(PluginId, CodeLensProvider)] -> PartialHandlers Config +codeLensHandlers :: [(PluginId, CodeLensProvider IdeState)] -> PartialHandlers Config codeLensHandlers cas = PartialHandlers $ \WithMessage{..} x -> return x { LSP.codeLensHandler = withResponse RspCodeLens (makeCodeLens cas) } -makeCodeLens :: [(PluginId, CodeLensProvider)] +makeCodeLens :: [(PluginId, CodeLensProvider IdeState)] -> LSP.LspFuncs Config -> IdeState -> CodeLensParams @@ -211,10 +185,10 @@ makeCodeLens cas lf ideState params = do -- ----------------------------------------------------------- -executeCommandPlugins :: [(PluginId, [PluginCommand])] -> Plugin Config +executeCommandPlugins :: [(PluginId, [PluginCommand IdeState])] -> Plugin Config executeCommandPlugins ecs = Plugin mempty (executeCommandHandlers ecs) -executeCommandHandlers :: [(PluginId, [PluginCommand])] -> PartialHandlers Config +executeCommandHandlers :: [(PluginId, [PluginCommand IdeState])] -> PartialHandlers Config executeCommandHandlers ecs = PartialHandlers $ \WithMessage{..} x -> return x{ LSP.executeCommandHandler = withResponseAndRequest RspExecuteCommand ReqApplyWorkspaceEdit (makeExecuteCommands ecs) } @@ -222,7 +196,7 @@ executeCommandHandlers ecs = PartialHandlers $ \WithMessage{..} x -> return x{ -- type ExecuteCommandProvider = IdeState -- -> ExecuteCommandParams -- -> IO (Either ResponseError Value, Maybe (ServerMethod, ApplyWorkspaceEditParams)) -makeExecuteCommands :: [(PluginId, [PluginCommand])] -> LSP.LspFuncs Config -> ExecuteCommandProvider +makeExecuteCommands :: [(PluginId, [PluginCommand IdeState])] -> LSP.LspFuncs Config -> ExecuteCommandProvider IdeState makeExecuteCommands ecs lf ide = wrapUnhandledExceptions $ do let pluginMap = Map.fromList ecs @@ -358,7 +332,7 @@ wrapUnhandledExceptions action input = -- | Runs a plugin command given a PluginId, CommandId and -- arguments in the form of a JSON object. -runPluginCommand :: Map.Map PluginId [PluginCommand] +runPluginCommand :: Map.Map PluginId [PluginCommand IdeState] -> LSP.LspFuncs Config -> IdeState -> PluginId @@ -390,7 +364,7 @@ runPluginCommand m lf ide p@(PluginId p') com@(CommandId com') arg = mkLspCommand :: PluginId -> CommandId -> T.Text -> Maybe [J.Value] -> IO Command mkLspCommand plid cn title args' = do - pid <- getPid + pid <- T.pack . show <$> getProcessID let cmdId = mkLspCmdId pid plid cn let args = List <$> args' return $ Command title cmdId args @@ -399,24 +373,19 @@ mkLspCmdId :: T.Text -> PluginId -> CommandId -> T.Text mkLspCmdId pid (PluginId plid) (CommandId cid) = pid <> ":" <> plid <> ":" <> cid -allLspCmdIds :: T.Text -> [(PluginId, [PluginCommand])] -> [T.Text] -allLspCmdIds pid commands = concat $ map go commands - where - go (plid, cmds) = map (mkLspCmdId pid plid . commandId) cmds - -- --------------------------------------------------------------------- -hoverPlugins :: [(PluginId, HoverProvider)] -> Plugin Config +hoverPlugins :: [(PluginId, HoverProvider IdeState)] -> Plugin Config hoverPlugins hs = Plugin hoverRules (hoverHandlers hs) hoverRules :: Rules () hoverRules = mempty -hoverHandlers :: [(PluginId, HoverProvider)] -> PartialHandlers Config +hoverHandlers :: [(PluginId, HoverProvider IdeState)] -> PartialHandlers Config hoverHandlers hps = PartialHandlers $ \WithMessage{..} x -> return x{LSP.hoverHandler = withResponse RspHover (makeHover hps)} -makeHover :: [(PluginId, HoverProvider)] +makeHover :: [(PluginId, HoverProvider IdeState)] -> LSP.LspFuncs Config -> IdeState -> TextDocumentPositionParams -> IO (Either ResponseError (Maybe Hover)) @@ -444,17 +413,17 @@ makeHover hps lf ideState params -- --------------------------------------------------------------------- -- --------------------------------------------------------------------- -symbolsPlugins :: [(PluginId, SymbolsProvider)] -> Plugin Config +symbolsPlugins :: [(PluginId, SymbolsProvider IdeState)] -> Plugin Config symbolsPlugins hs = Plugin symbolsRules (symbolsHandlers hs) symbolsRules :: Rules () symbolsRules = mempty -symbolsHandlers :: [(PluginId, SymbolsProvider)] -> PartialHandlers Config +symbolsHandlers :: [(PluginId, SymbolsProvider IdeState)] -> PartialHandlers Config symbolsHandlers hps = PartialHandlers $ \WithMessage{..} x -> return x {LSP.documentSymbolHandler = withResponse RspDocumentSymbols (makeSymbols hps)} -makeSymbols :: [(PluginId, SymbolsProvider)] +makeSymbols :: [(PluginId, SymbolsProvider IdeState)] -> LSP.LspFuncs Config -> IdeState -> DocumentSymbolParams @@ -493,7 +462,7 @@ makeSymbols sps lf ideState params -- --------------------------------------------------------------------- -- --------------------------------------------------------------------- -renamePlugins :: [(PluginId, RenameProvider)] -> Plugin Config +renamePlugins :: [(PluginId, RenameProvider IdeState)] -> Plugin Config renamePlugins providers = Plugin rules handlers where rules = mempty @@ -501,7 +470,7 @@ renamePlugins providers = Plugin rules handlers { LSP.renameHandler = withResponse RspRename (renameWith providers)} renameWith :: - [(PluginId, RenameProvider)] -> + [(PluginId, RenameProvider IdeState)] -> LSP.LspFuncs Config -> IdeState -> RenameParams -> @@ -522,7 +491,7 @@ renameWith providers lspFuncs state params = do -- --------------------------------------------------------------------- -- --------------------------------------------------------------------- -formatterPlugins :: [(PluginId, FormattingProvider IO)] -> Plugin Config +formatterPlugins :: [(PluginId, FormattingProvider IdeState IO)] -> Plugin Config formatterPlugins providers = Plugin formatterRules (formatterHandlers (Map.fromList (("none",noneProvider):providers))) @@ -530,7 +499,7 @@ formatterPlugins providers formatterRules :: Rules () formatterRules = mempty -formatterHandlers :: Map.Map PluginId (FormattingProvider IO) -> PartialHandlers Config +formatterHandlers :: Map.Map PluginId (FormattingProvider IdeState IO) -> PartialHandlers Config formatterHandlers providers = PartialHandlers $ \WithMessage{..} x -> return x { LSP.documentFormattingHandler = withResponse RspDocumentFormatting (formatting providers) @@ -541,17 +510,17 @@ formatterHandlers providers = PartialHandlers $ \WithMessage{..} x -> return x -- --------------------------------------------------------------------- -- --------------------------------------------------------------------- -completionsPlugins :: [(PluginId, CompletionProvider)] -> Plugin Config +completionsPlugins :: [(PluginId, CompletionProvider IdeState)] -> Plugin Config completionsPlugins cs = Plugin completionsRules (completionsHandlers cs) completionsRules :: Rules () completionsRules = mempty -completionsHandlers :: [(PluginId, CompletionProvider)] -> PartialHandlers Config +completionsHandlers :: [(PluginId, CompletionProvider IdeState)] -> PartialHandlers Config completionsHandlers cps = PartialHandlers $ \WithMessage{..} x -> return x {LSP.completionHandler = withResponse RspCompletion (makeCompletions cps)} -makeCompletions :: [(PluginId, CompletionProvider)] +makeCompletions :: [(PluginId, CompletionProvider IdeState)] -> LSP.LspFuncs Config -> IdeState -> CompletionParams @@ -614,47 +583,3 @@ getPrefixAtPos lf uri pos = do case mvf of Just vf -> VFS.getCompletionPrefix pos vf Nothing -> return Nothing - --- --------------------------------------------------------------------- --- | Returns the current client configuration. It is not wise to permanently --- cache the returned value of this function, as clients can change their --- configuration at runtime. --- --- If no custom configuration has been set by the client, this function returns --- our own defaults. -getClientConfig :: LSP.LspFuncs Config -> IO Config -getClientConfig lf = fromMaybe Data.Default.def <$> LSP.config lf - --- | Returns the client configuration stored in the IdeState. --- You can use this function to access it from shake Rules -getClientConfigAction :: Action Config -getClientConfigAction = do - mbVal <- unhashed <$> useNoFile_ GetClientSettings - logm $ "getClientConfigAction:clientSettings:" ++ show mbVal - case J.fromJSON <$> mbVal of - Just (J.Success c) -> return c - _ -> return Data.Default.def - --- --------------------------------------------------------------------- - --- | Returns the current plugin configuration. It is not wise to permanently --- cache the returned value of this function, as clients can change their --- configuration at runtime. --- --- If no custom configuration has been set by the client, this function returns --- our own defaults. -getPluginConfig :: LSP.LspFuncs Config -> PluginId -> IO PluginConfig -getPluginConfig lf plugin = do - config <- getClientConfig lf - return $ configForPlugin config plugin - -configForPlugin :: Config -> PluginId -> PluginConfig -configForPlugin config (PluginId plugin) - = Map.findWithDefault Data.Default.def plugin (plugins config) - --- --------------------------------------------------------------------- - --- | Checks that a given plugin is both enabled and the specific feature is --- enabled -pluginEnabled :: PluginConfig -> (PluginConfig -> Bool) -> Bool -pluginEnabled pluginConfig f = plcGlobalOn pluginConfig && f pluginConfig diff --git a/hls-plugin-api/src/Ide/Plugin/Formatter.hs b/ghcide/src/Development/IDE/Plugin/HLS/Formatter.hs similarity index 67% rename from hls-plugin-api/src/Ide/Plugin/Formatter.hs rename to ghcide/src/Development/IDE/Plugin/HLS/Formatter.hs index ba78c24c9c..c5e9185945 100644 --- a/hls-plugin-api/src/Ide/Plugin/Formatter.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS/Formatter.hs @@ -4,20 +4,17 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} -module Ide.Plugin.Formatter +module Development.IDE.Plugin.HLS.Formatter ( formatting , rangeFormatting - , noneProvider - , responseError - , extractRange - , fullRange ) where import qualified Data.Map as Map import qualified Data.Text as T import Development.IDE +import Ide.PluginUtils import Ide.Types import Ide.Plugin.Config import qualified Language.Haskell.LSP.Core as LSP @@ -26,7 +23,7 @@ import Text.Regex.TDFA.Text() -- --------------------------------------------------------------------- -formatting :: Map.Map PluginId (FormattingProvider IO) +formatting :: Map.Map PluginId (FormattingProvider IdeState IO) -> LSP.LspFuncs Config -> IdeState -> DocumentFormattingParams -> IO (Either ResponseError (List TextEdit)) formatting providers lf ideState @@ -35,7 +32,7 @@ formatting providers lf ideState -- --------------------------------------------------------------------- -rangeFormatting :: Map.Map PluginId (FormattingProvider IO) +rangeFormatting :: Map.Map PluginId (FormattingProvider IdeState IO) -> LSP.LspFuncs Config -> IdeState -> DocumentRangeFormattingParams -> IO (Either ResponseError (List TextEdit)) rangeFormatting providers lf ideState @@ -44,7 +41,7 @@ rangeFormatting providers lf ideState -- --------------------------------------------------------------------- -doFormatting :: LSP.LspFuncs Config -> Map.Map PluginId (FormattingProvider IO) +doFormatting :: LSP.LspFuncs Config -> Map.Map PluginId (FormattingProvider IdeState IO) -> IdeState -> FormattingType -> Uri -> FormattingOptions -> IO (Either ResponseError (List TextEdit)) doFormatting lf providers ideState ft uri params = do @@ -76,35 +73,3 @@ doFormatting lf providers ideState ft uri params = do else "" ] --- --------------------------------------------------------------------- - -noneProvider :: FormattingProvider IO -noneProvider _ _ _ _ _ _ = return $ Right (List []) - --- --------------------------------------------------------------------- - -responseError :: T.Text -> ResponseError -responseError txt = ResponseError InvalidParams txt Nothing - --- --------------------------------------------------------------------- - -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 - newS = T.unlines focusLines - --- | Gets the range that covers the entire text -fullRange :: T.Text -> Range -fullRange s = Range startPos endPos - where startPos = Position 0 0 - endPos = Position lastLine 0 - {- - In order to replace everything including newline characters, - the end range should extend below the last line. From the specification: - "If you want to specify a range that contains a line including - the line ending character(s) then use an end position denoting - the start of the next line" - -} - lastLine = length $ T.lines s - --- --------------------------------------------------------------------- diff --git a/hls-plugin-api/src/Ide/Plugin/GhcIde.hs b/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs similarity index 84% rename from hls-plugin-api/src/Ide/Plugin/GhcIde.hs rename to ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs index 9690c0a889..fc90407097 100644 --- a/hls-plugin-api/src/Ide/Plugin/GhcIde.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs @@ -1,6 +1,8 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE OverloadedStrings #-} -module Ide.Plugin.GhcIde + +-- | Exposes the ghcide features as an HLS plugin +module Development.IDE.Plugin.HLS.GhcIde ( descriptor ) where @@ -11,14 +13,14 @@ import Development.IDE.Plugin.Completions import Development.IDE.Plugin.CodeAction import Development.IDE.LSP.HoverDefinition import Development.IDE.LSP.Outline -import Ide.Plugin +import Ide.PluginUtils import Ide.Types import Language.Haskell.LSP.Types import Text.Regex.TDFA.Text() -- --------------------------------------------------------------------- -descriptor :: PluginId -> PluginDescriptor +descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) { pluginCommands = [PluginCommand (CommandId "typesignature.add") "adds a signature" commandAddSignature] , pluginCodeActionProvider = Just codeAction' @@ -30,30 +32,30 @@ descriptor plId = (defaultPluginDescriptor plId) -- --------------------------------------------------------------------- -hover' :: HoverProvider +hover' :: HoverProvider IdeState hover' ideState params = do logInfo (ideLogger ideState) "GhcIde.hover entered (ideLogger)" -- AZ hover ideState params -- --------------------------------------------------------------------- -commandAddSignature :: CommandFunction WorkspaceEdit +commandAddSignature :: CommandFunction IdeState WorkspaceEdit commandAddSignature lf ide params = commandHandler lf ide (ExecuteCommandParams "typesignature.add" (Just (List [toJSON params])) Nothing) -- --------------------------------------------------------------------- -codeAction' :: CodeActionProvider +codeAction' :: CodeActionProvider IdeState codeAction' lf ide _ doc range context = fmap List <$> codeAction lf ide doc range context -- --------------------------------------------------------------------- -codeLens' :: CodeLensProvider +codeLens' :: CodeLensProvider IdeState codeLens' lf ide _ params = codeLens lf ide params -- --------------------------------------------------------------------- -symbolsProvider :: SymbolsProvider +symbolsProvider :: SymbolsProvider IdeState symbolsProvider ls ide params = do ds <- moduleOutline ls ide params case ds of diff --git a/hls-plugin-api/hls-plugin-api.cabal b/hls-plugin-api/hls-plugin-api.cabal index f88f7be36a..a860049f85 100644 --- a/hls-plugin-api/hls-plugin-api.cabal +++ b/hls-plugin-api/hls-plugin-api.cabal @@ -26,10 +26,7 @@ source-repository head library exposed-modules: Ide.Logger - Ide.Plugin Ide.Plugin.Config - Ide.Plugin.Formatter - Ide.Plugin.GhcIde Ide.PluginUtils Ide.Types @@ -40,9 +37,6 @@ library , containers , data-default , Diff - , ghc - , ghc-boot-th - , ghcide >=0.5 , haskell-lsp ^>=0.22 , hashable , hslogger @@ -53,6 +47,13 @@ library , text , unordered-containers + if os(windows) + build-depends: + Win32 + else + build-depends: + unix + ghc-options: -Wall -Wredundant-constraints -Wno-name-shadowing if flag(pedantic) diff --git a/hls-plugin-api/src/Ide/Logger.hs b/hls-plugin-api/src/Ide/Logger.hs index bd720ffc20..1f960d8688 100644 --- a/hls-plugin-api/src/Ide/Logger.hs +++ b/hls-plugin-api/src/Ide/Logger.hs @@ -3,31 +3,17 @@ -} module Ide.Logger ( - hlsLogger - , logm + logm , debugm , warningm , errorm ) where import Control.Monad.IO.Class -import qualified Data.Text as T -import qualified Development.IDE.Types.Logger as L import System.Log.Logger -- --------------------------------------------------------------------- -hlsLogger :: L.Logger -hlsLogger = L.Logger $ \pri txt -> - case pri of - L.Telemetry -> logm (T.unpack txt) - L.Debug -> debugm (T.unpack txt) - L.Info -> logm (T.unpack txt) - L.Warning -> warningm (T.unpack txt) - L.Error -> errorm (T.unpack txt) - --- --------------------------------------------------------------------- - logm :: MonadIO m => String -> m () logm s = liftIO $ infoM "hls" s diff --git a/hls-plugin-api/src/Ide/PluginUtils.hs b/hls-plugin-api/src/Ide/PluginUtils.hs index 442cc770f7..caa0768c0e 100644 --- a/hls-plugin-api/src/Ide/PluginUtils.hs +++ b/hls-plugin-api/src/Ide/PluginUtils.hs @@ -1,14 +1,47 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -module Ide.PluginUtils where +module Ide.PluginUtils + ( WithDeletions(..), + getProcessID, + normalize, + makeDiffTextEdit, + makeDiffTextEditAdditive, + diffText, + diffText', + pluginDescToIdePlugins, + responseError, + getClientConfig, + getPluginConfig, + configForPlugin, + pluginEnabled, + extractRange, + fullRange, + mkLspCommand, + mkLspCmdId, + allLspCmdIds,allLspCmdIds') +where + -import qualified Data.Text as T -import Data.Maybe -import Data.Algorithm.DiffOutput import Data.Algorithm.Diff -import qualified Data.HashMap.Strict as H -import Language.Haskell.LSP.Types.Capabilities -import qualified Language.Haskell.LSP.Types as J +import Data.Algorithm.DiffOutput +import qualified Data.HashMap.Strict as H +import Data.Maybe +import qualified Data.Text as T +import Ide.Types import Language.Haskell.LSP.Types +import qualified Language.Haskell.LSP.Types as J +import Language.Haskell.LSP.Types.Capabilities + +#ifdef mingw32_HOST_OS +import qualified System.Win32.Process as P (getCurrentProcessId) +#else +import qualified System.Posix.Process as P (getProcessID) +#endif +import qualified Data.Aeson as J +import qualified Data.Default +import qualified Data.Map.Strict as Map +import Ide.Plugin.Config +import qualified Language.Haskell.LSP.Core as LSP -- --------------------------------------------------------------------- @@ -45,7 +78,7 @@ diffTextEdit fText f2Text withDeletions = J.List r (diffToLineRanges d) isDeletion (Deletion _ _) = True - isDeletion _ = False + isDeletion _ = False diffOperationToTextEdit :: DiffOperation LineRange -> J.TextEdit @@ -108,3 +141,113 @@ clientSupportsDocumentChanges caps = mDc in fromMaybe False supports + +-- --------------------------------------------------------------------- + +pluginDescToIdePlugins :: [PluginDescriptor ideState] -> IdePlugins ideState +pluginDescToIdePlugins plugins = IdePlugins $ Map.fromList $ map (\p -> (pluginId p, p)) plugins + + +-- --------------------------------------------------------------------- + +responseError :: T.Text -> ResponseError +responseError txt = ResponseError InvalidParams txt Nothing + + +-- --------------------------------------------------------------------- +-- | Returns the current client configuration. It is not wise to permanently +-- cache the returned value of this function, as clients can at runitime change +-- their configuration. +-- +-- If no custom configuration has been set by the client, this function returns +-- our own defaults. +getClientConfig :: LSP.LspFuncs Config -> IO Config +getClientConfig lf = fromMaybe Data.Default.def <$> LSP.config lf + +-- --------------------------------------------------------------------- + +-- | Returns the current plugin configuration. It is not wise to permanently +-- cache the returned value of this function, as clients can change their +-- configuration at runtime. +-- +-- If no custom configuration has been set by the client, this function returns +-- our own defaults. +getPluginConfig :: LSP.LspFuncs Config -> PluginId -> IO PluginConfig +getPluginConfig lf plugin = do + config <- getClientConfig lf + return $ configForPlugin config plugin + +configForPlugin :: Config -> PluginId -> PluginConfig +configForPlugin config (PluginId plugin) + = Map.findWithDefault Data.Default.def plugin (plugins config) + +-- --------------------------------------------------------------------- + +-- | Checks that a given plugin is both enabled and the specific feature is +-- enabled +pluginEnabled :: PluginConfig -> (PluginConfig -> Bool) -> Bool +pluginEnabled pluginConfig f = plcGlobalOn pluginConfig && f pluginConfig + +-- --------------------------------------------------------------------- + +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 + newS = T.unlines focusLines + +-- | Gets the range that covers the entire text +fullRange :: T.Text -> Range +fullRange s = Range startPos endPos + where startPos = Position 0 0 + endPos = Position lastLine 0 + {- + In order to replace everything including newline characters, + the end range should extend below the last line. From the specification: + "If you want to specify a range that contains a line including + the line ending character(s) then use an end position denoting + the start of the next line" + -} + lastLine = length $ T.lines s + +-- --------------------------------------------------------------------- + +allLspCmdIds' :: T.Text -> IdePlugins ideState -> [T.Text] +allLspCmdIds' pid mp = mkPlugin (allLspCmdIds pid) (Just . pluginCommands) + where + justs (p, Just x) = [(p, x)] + justs (_, Nothing) = [] + + ls = Map.toList (ipMap mp) + + mkPlugin maker selector + = maker $ concatMap (\(pid, p) -> justs (pid, selector p)) ls + + +allLspCmdIds :: T.Text -> [(PluginId, [PluginCommand ideState])] -> [T.Text] +allLspCmdIds pid commands = concat $ map go commands + where + go (plid, cmds) = map (mkLspCmdId pid plid . commandId) cmds + +mkLspCommand :: PluginId -> CommandId -> T.Text -> Maybe [J.Value] -> IO Command +mkLspCommand plid cn title args' = do + pid <- getPid + let cmdId = mkLspCmdId pid plid cn + let args = List <$> args' + return $ Command title cmdId args + +mkLspCmdId :: T.Text -> PluginId -> CommandId -> T.Text +mkLspCmdId pid (PluginId plid) (CommandId cid) + = pid <> ":" <> plid <> ":" <> cid + +-- | Get the operating system process id for the running server +-- instance. This should be the same for the lifetime of the instance, +-- and different from that of any other currently running instance. +getPid :: IO T.Text +getPid = T.pack . show <$> getProcessID + +getProcessID :: IO Int +#ifdef mingw32_HOST_OS +getProcessID = fromIntegral <$> P.getCurrentProcessId +#else +getProcessID = fromIntegral <$> P.getProcessID +#endif diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index 071b9572cb..76b94189de 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -15,6 +15,7 @@ module Ide.Types , SymbolsProvider , FormattingType(..) , FormattingProvider + , noneProvider , HoverProvider , CodeActionProvider , CodeLensProvider @@ -30,7 +31,7 @@ import qualified Data.Map as Map import qualified Data.Set as S import Data.String import qualified Data.Text as T -import Development.IDE +import Development.Shake import Ide.Plugin.Config import qualified Language.Haskell.LSP.Core as LSP import Language.Haskell.LSP.Types @@ -38,29 +39,28 @@ import Text.Regex.TDFA.Text() -- --------------------------------------------------------------------- -newtype IdePlugins = IdePlugins - { ipMap :: Map.Map PluginId PluginDescriptor - } +newtype IdePlugins ideState = IdePlugins + { ipMap :: Map.Map PluginId (PluginDescriptor ideState)} -- --------------------------------------------------------------------- -data PluginDescriptor = +data PluginDescriptor ideState = PluginDescriptor { pluginId :: !PluginId , pluginRules :: !(Rules ()) - , pluginCommands :: ![PluginCommand] - , pluginCodeActionProvider :: !(Maybe CodeActionProvider) - , pluginCodeLensProvider :: !(Maybe CodeLensProvider) + , pluginCommands :: ![PluginCommand ideState] + , pluginCodeActionProvider :: !(Maybe (CodeActionProvider ideState)) + , pluginCodeLensProvider :: !(Maybe (CodeLensProvider ideState)) , pluginDiagnosticProvider :: !(Maybe DiagnosticProvider) -- ^ TODO: diagnostics are generally provided via rules, -- this is probably redundant. - , pluginHoverProvider :: !(Maybe HoverProvider) - , pluginSymbolsProvider :: !(Maybe SymbolsProvider) - , pluginFormattingProvider :: !(Maybe (FormattingProvider IO)) - , pluginCompletionProvider :: !(Maybe CompletionProvider) - , pluginRenameProvider :: !(Maybe RenameProvider) + , pluginHoverProvider :: !(Maybe (HoverProvider ideState)) + , pluginSymbolsProvider :: !(Maybe (SymbolsProvider ideState)) + , pluginFormattingProvider :: !(Maybe (FormattingProvider ideState IO)) + , pluginCompletionProvider :: !(Maybe (CompletionProvider ideState)) + , pluginRenameProvider :: !(Maybe (RenameProvider ideState)) } -defaultPluginDescriptor :: PluginId -> PluginDescriptor +defaultPluginDescriptor :: PluginId -> PluginDescriptor ideState defaultPluginDescriptor plId = PluginDescriptor plId @@ -94,42 +94,43 @@ newtype CommandId = CommandId T.Text instance IsString CommandId where fromString = CommandId . T.pack -data PluginCommand = forall a. (FromJSON a) => +data PluginCommand ideState = forall a. (FromJSON a) => PluginCommand { commandId :: CommandId , commandDesc :: T.Text - , commandFunc :: CommandFunction a + , commandFunc :: CommandFunction ideState a } + -- --------------------------------------------------------------------- -type CommandFunction a = LSP.LspFuncs Config - -> IdeState +type CommandFunction ideState a = LSP.LspFuncs Config + -> ideState -> a -> IO (Either ResponseError Value, Maybe (ServerMethod, ApplyWorkspaceEditParams)) -type CodeActionProvider = LSP.LspFuncs Config - -> IdeState +type CodeActionProvider ideState = LSP.LspFuncs Config + -> ideState -> PluginId -> TextDocumentIdentifier -> Range -> CodeActionContext -> IO (Either ResponseError (List CAResult)) -type CompletionProvider = LSP.LspFuncs Config - -> IdeState +type CompletionProvider ideState = LSP.LspFuncs Config + -> ideState -> CompletionParams -> IO (Either ResponseError CompletionResponseResult) -type CodeLensProvider = LSP.LspFuncs Config - -> IdeState +type CodeLensProvider ideState = LSP.LspFuncs Config + -> ideState -> PluginId -> CodeLensParams -> IO (Either ResponseError (List CodeLens)) -type RenameProvider = LSP.LspFuncs Config - -> IdeState +type RenameProvider ideState = LSP.LspFuncs Config + -> ideState -> RenameParams -> IO (Either ResponseError WorkspaceEdit) @@ -158,14 +159,14 @@ data DiagnosticTrigger = DiagnosticOnOpen deriving (Show,Ord,Eq) -- type HoverProvider = Uri -> Position -> IO (Either ResponseError [Hover]) -type HoverProvider = IdeState -> TextDocumentPositionParams -> IO (Either ResponseError (Maybe Hover)) +type HoverProvider ideState = ideState -> TextDocumentPositionParams -> IO (Either ResponseError (Maybe Hover)) -type SymbolsProvider = LSP.LspFuncs Config - -> IdeState +type SymbolsProvider ideState = LSP.LspFuncs Config + -> ideState -> DocumentSymbolParams -> IO (Either ResponseError [DocumentSymbol]) -type ExecuteCommandProvider = IdeState +type ExecuteCommandProvider ideState = ideState -> ExecuteCommandParams -> IO (Either ResponseError Value, Maybe (ServerMethod, ApplyWorkspaceEditParams)) @@ -192,13 +193,14 @@ data FormattingType = FormatText -- | To format a whole document, the 'FormatText' @FormattingType@ can be used. -- It is required to pass in the whole Document Text for that to happen, an empty text -- and file uri, does not suffice. -type FormattingProvider m +type FormattingProvider ideState m = LSP.LspFuncs Config - -> IdeState + -> ideState -> FormattingType -- ^ How much to format -> T.Text -- ^ Text to format -> NormalizedFilePath -- ^ location of the file being formatted -> FormattingOptions -- ^ Options for the formatter -> m (Either ResponseError (List TextEdit)) -- ^ Result of the formatting --- --------------------------------------------------------------------- +noneProvider :: FormattingProvider ideState IO +noneProvider _ _ _ _ _ _ = return $ Right (List []) diff --git a/plugins/default/src/Ide/Plugin/Brittany.hs b/plugins/default/src/Ide/Plugin/Brittany.hs index 0d68bb9f0f..6001363181 100644 --- a/plugins/default/src/Ide/Plugin/Brittany.hs +++ b/plugins/default/src/Ide/Plugin/Brittany.hs @@ -8,17 +8,17 @@ import Data.Semigroup import Data.Text (Text) import qualified Data.Text as T import Development.IDE +-- import Development.IDE.Plugin.Formatter import Language.Haskell.Brittany import Language.Haskell.LSP.Types as J import qualified Language.Haskell.LSP.Types.Lens as J -import Ide.Plugin.Formatter import Ide.PluginUtils import Ide.Types import System.FilePath import Data.Maybe (maybeToList) -descriptor :: PluginId -> PluginDescriptor +descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) { pluginFormattingProvider = Just provider } @@ -27,7 +27,7 @@ descriptor plId = (defaultPluginDescriptor plId) -- Formats the given source in either a given Range or the whole Document. -- If the provider fails an error is returned that can be displayed to the user. provider - :: FormattingProvider IO + :: FormattingProvider IdeState IO provider _lf _ideState typ contents fp opts = do -- text uri formatType opts = pluginGetFile "brittanyCmd: " uri $ \fp -> do confFile <- liftIO $ getConfFile fp diff --git a/plugins/default/src/Ide/Plugin/Example.hs b/plugins/default/src/Ide/Plugin/Example.hs index 612e85bc1b..851810dc0b 100644 --- a/plugins/default/src/Ide/Plugin/Example.hs +++ b/plugins/default/src/Ide/Plugin/Example.hs @@ -27,14 +27,14 @@ import Development.IDE.GHC.Compat (ParsedModule(ParsedModule)) import Development.IDE.Core.Rules (useE) import Development.IDE.Core.Shake (getDiagnostics, getHiddenDiagnostics) import GHC.Generics -import Ide.Plugin +import Ide.PluginUtils import Ide.Types import Language.Haskell.LSP.Types import Text.Regex.TDFA.Text() -- --------------------------------------------------------------------- -descriptor :: PluginId -> PluginDescriptor +descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) { pluginRules = exampleRules , pluginCommands = [PluginCommand "codelens.todo" "example adding" addTodoCmd] @@ -99,7 +99,7 @@ mkDiag file diagSource sev loc msg = (file, D.ShowDiag,) -- --------------------------------------------------------------------- -- | Generate code actions. -codeAction :: CodeActionProvider +codeAction :: CodeActionProvider IdeState codeAction _lf state _pid (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=List _xs} = do let Just nfp = uriToNormalizedFilePath $ toNormalizedUri uri Just (ParsedModule{},_) <- runIdeAction "example" (shakeExtras state) $ useWithStaleFast GetParsedModule nfp @@ -113,7 +113,7 @@ codeAction _lf state _pid (TextDocumentIdentifier uri) _range CodeActionContext{ -- --------------------------------------------------------------------- -codeLens :: CodeLensProvider +codeLens :: CodeLensProvider IdeState codeLens _lf ideState plId CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do logInfo (ideLogger ideState) "Example.codeLens entered (ideLogger)" -- AZ case uriToFilePath' uri of @@ -140,7 +140,7 @@ data AddTodoParams = AddTodoParams } deriving (Show, Eq, Generic, ToJSON, FromJSON) -addTodoCmd :: CommandFunction AddTodoParams +addTodoCmd :: CommandFunction IdeState AddTodoParams addTodoCmd _lf _ide (AddTodoParams uri todoText) = do let pos = Position 3 0 @@ -187,7 +187,7 @@ logAndRunRequest label getResults ide pos path = do -- --------------------------------------------------------------------- -symbols :: SymbolsProvider +symbols :: SymbolsProvider IdeState symbols _lf _ide (DocumentSymbolParams _doc _mt) = pure $ Right [r] where @@ -202,7 +202,7 @@ symbols _lf _ide (DocumentSymbolParams _doc _mt) -- --------------------------------------------------------------------- -completion :: CompletionProvider +completion :: CompletionProvider IdeState completion _lf _ide (CompletionParams _doc _pos _mctxt _mt) = pure $ Right $ Completions $ List [r] where diff --git a/plugins/default/src/Ide/Plugin/Example2.hs b/plugins/default/src/Ide/Plugin/Example2.hs index 9ddc51de76..7640ce9abe 100644 --- a/plugins/default/src/Ide/Plugin/Example2.hs +++ b/plugins/default/src/Ide/Plugin/Example2.hs @@ -26,14 +26,14 @@ import Development.IDE as D import Development.IDE.Core.Rules import Development.IDE.Core.Shake import GHC.Generics -import Ide.Plugin +import Ide.PluginUtils import Ide.Types import Language.Haskell.LSP.Types import Text.Regex.TDFA.Text() -- --------------------------------------------------------------------- -descriptor :: PluginId -> PluginDescriptor +descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) { pluginRules = exampleRules , pluginCommands = [PluginCommand "codelens.todo" "example adding" addTodoCmd] @@ -98,7 +98,7 @@ mkDiag file diagSource sev loc msg = (file, D.ShowDiag,) -- --------------------------------------------------------------------- -- | Generate code actions. -codeAction :: CodeActionProvider +codeAction :: CodeActionProvider IdeState codeAction _lf _state _pid (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=List _xs} = do let title = "Add TODO2 Item" @@ -110,7 +110,7 @@ codeAction _lf _state _pid (TextDocumentIdentifier uri) _range CodeActionContext -- --------------------------------------------------------------------- -codeLens :: CodeLensProvider +codeLens :: CodeLensProvider IdeState codeLens _lf ideState plId CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do logInfo (ideLogger ideState) "Example2.codeLens entered (ideLogger)" -- AZ case uriToFilePath' uri of @@ -134,7 +134,7 @@ data AddTodoParams = AddTodoParams } deriving (Show, Eq, Generic, ToJSON, FromJSON) -addTodoCmd :: CommandFunction AddTodoParams +addTodoCmd :: CommandFunction IdeState AddTodoParams addTodoCmd _lf _ide (AddTodoParams uri todoText) = do let pos = Position 5 0 @@ -181,7 +181,7 @@ logAndRunRequest label getResults ide pos path = do -- --------------------------------------------------------------------- -symbols :: SymbolsProvider +symbols :: SymbolsProvider IdeState symbols _lf _ide (DocumentSymbolParams _doc _mt) = pure $ Right [r] where @@ -196,7 +196,7 @@ symbols _lf _ide (DocumentSymbolParams _doc _mt) -- --------------------------------------------------------------------- -completion :: CompletionProvider +completion :: CompletionProvider IdeState completion _lf _ide (CompletionParams _doc _pos _mctxt _mt) = pure $ Right $ Completions $ List [r] where diff --git a/plugins/default/src/Ide/Plugin/Floskell.hs b/plugins/default/src/Ide/Plugin/Floskell.hs index 2628646973..3c8aa8e590 100644 --- a/plugins/default/src/Ide/Plugin/Floskell.hs +++ b/plugins/default/src/Ide/Plugin/Floskell.hs @@ -16,14 +16,14 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as T import Development.IDE as D import Floskell -import Ide.Plugin.Formatter +import Ide.PluginUtils import Ide.Types import Language.Haskell.LSP.Types import Text.Regex.TDFA.Text() -- --------------------------------------------------------------------- -descriptor :: PluginId -> PluginDescriptor +descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) { pluginFormattingProvider = Just provider } @@ -33,7 +33,7 @@ descriptor plId = (defaultPluginDescriptor plId) -- | Format provider of Floskell. -- Formats the given source in either a given Range or the whole Document. -- If the provider fails an error is returned that can be displayed to the user. -provider :: FormattingProvider IO +provider :: FormattingProvider IdeState IO provider _lf _ideState typ contents fp _ = do let file = fromNormalizedFilePath fp config <- findConfigOrDefault file diff --git a/plugins/default/src/Ide/Plugin/Fourmolu.hs b/plugins/default/src/Ide/Plugin/Fourmolu.hs index 5a3810290b..e82b1b1fad 100644 --- a/plugins/default/src/Ide/Plugin/Fourmolu.hs +++ b/plugins/default/src/Ide/Plugin/Fourmolu.hs @@ -21,8 +21,7 @@ import qualified EnumSet as S import GHC (DynFlags, moduleNameString) import GHC.LanguageExtensions.Type (Extension (Cpp)) import GhcPlugins (HscEnv (hsc_dflags)) -import Ide.Plugin.Formatter (responseError) -import Ide.PluginUtils (makeDiffTextEdit) +import Ide.PluginUtils (responseError, makeDiffTextEdit) import Language.Haskell.LSP.Messages (FromServerMessage (ReqShowMessage)) import Ide.Types @@ -33,7 +32,7 @@ import "fourmolu" Ormolu -- --------------------------------------------------------------------- -descriptor :: PluginId -> PluginDescriptor +descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) { pluginFormattingProvider = Just provider @@ -41,7 +40,7 @@ descriptor plId = -- --------------------------------------------------------------------- -provider :: FormattingProvider IO +provider :: FormattingProvider IdeState IO provider lf ideState typ contents fp fo = withIndefiniteProgress lf title Cancellable $ do ghc <- runAction "Fourmolu" ideState $ use GhcSession fp fileOpts <- case hsc_dflags . hscEnv <$> ghc of diff --git a/plugins/default/src/Ide/Plugin/ModuleName.hs b/plugins/default/src/Ide/Plugin/ModuleName.hs index a1bfb34432..d12d541acf 100644 --- a/plugins/default/src/Ide/Plugin/ModuleName.hs +++ b/plugins/default/src/Ide/Plugin/ModuleName.hs @@ -24,7 +24,7 @@ import qualified Data.HashMap.Strict as Map import Data.List (find, intercalate, isPrefixOf) import Data.Maybe (maybeToList) import Data.String (IsString) -import Data.Text (Text) +import Data.Text (Text, pack) import qualified Data.Text as T -- import Debug.Trace (trace) import Development.IDE ( @@ -47,7 +47,6 @@ import Development.IDE ( use, use_, ) -import Development.IDE.Plugin (getPid) import GHC ( DynFlags (importPaths), GenLocated (L), @@ -57,7 +56,7 @@ import GHC ( getSessionDynFlags, unLoc, ) -import Ide.Plugin (mkLspCmdId) +import Ide.PluginUtils (mkLspCmdId, getProcessID) import Ide.Types ( CommandFunction, PluginCommand (..), @@ -92,7 +91,7 @@ import System.FilePath ( ) -- |Plugin descriptor -descriptor :: PluginId -> PluginDescriptor +descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) { pluginCodeLensProvider = Just codeLens @@ -118,11 +117,11 @@ codeLens :: IO (Either a2 (List CodeLens)) codeLens lsp state pluginId (CodeLensParams (TextDocumentIdentifier uri) _) = do - pid <- getPid + pid <- pack . show <$> getProcessID Right . List . maybeToList . (asCodeLens (mkLspCmdId pid pluginId editCommandName) <$>) <$> action lsp state uri -- | (Quasi) Idempotent command execution: recalculate action to execute on command request -command :: CommandFunction Uri +command :: CommandFunction IdeState Uri command lsp state uri = do actMaybe <- action lsp state uri return diff --git a/plugins/default/src/Ide/Plugin/Ormolu.hs b/plugins/default/src/Ide/Plugin/Ormolu.hs index 094e513ae9..32fbef3946 100644 --- a/plugins/default/src/Ide/Plugin/Ormolu.hs +++ b/plugins/default/src/Ide/Plugin/Ormolu.hs @@ -19,7 +19,6 @@ import qualified EnumSet as S import GHC import GHC.LanguageExtensions.Type import GhcPlugins (HscEnv (hsc_dflags)) -import Ide.Plugin.Formatter import Ide.PluginUtils import Ide.Types import Language.Haskell.LSP.Core (LspFuncs (withIndefiniteProgress), @@ -31,14 +30,14 @@ import Text.Regex.TDFA.Text () -- --------------------------------------------------------------------- -descriptor :: PluginId -> PluginDescriptor +descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) { pluginFormattingProvider = Just provider } -- --------------------------------------------------------------------- -provider :: FormattingProvider IO +provider :: FormattingProvider IdeState IO provider lf ideState typ contents fp _ = withIndefiniteProgress lf title Cancellable $ do let fromDyn :: DynFlags -> IO [DynOption] diff --git a/plugins/default/src/Ide/Plugin/Pragmas.hs b/plugins/default/src/Ide/Plugin/Pragmas.hs index b53be45294..9e3f7d0ca0 100644 --- a/plugins/default/src/Ide/Plugin/Pragmas.hs +++ b/plugins/default/src/Ide/Plugin/Pragmas.hs @@ -29,7 +29,7 @@ import qualified Language.Haskell.LSP.VFS as VFS -- --------------------------------------------------------------------- -descriptor :: PluginId -> PluginDescriptor +descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) { pluginCodeActionProvider = Just codeActionProvider , pluginCompletionProvider = Just completion @@ -48,7 +48,6 @@ data AddPragmaParams = AddPragmaParams -- Pragma is added to the first line of the Uri. -- It is assumed that the pragma name is a valid pragma, -- thus, not validated. --- mkPragmaEdit :: CommandFunction AddPragmaParams mkPragmaEdit :: Uri -> T.Text -> WorkspaceEdit mkPragmaEdit uri pragmaName = res where pos = J.Position 0 0 @@ -63,7 +62,7 @@ mkPragmaEdit uri pragmaName = res where -- --------------------------------------------------------------------- -- | Offer to add a missing Language Pragma to the top of a file. -- Pragmas are defined by a curated list of known pragmas, see 'possiblePragmas'. -codeActionProvider :: CodeActionProvider +codeActionProvider :: CodeActionProvider IdeState codeActionProvider _ state _plId docId _ (J.CodeActionContext (J.List diags) _monly) = do let mFile = docId ^. J.uri & uriToFilePath <&> toNormalizedFilePath' pm <- fmap join $ runAction "addPragma" state $ getParsedModule `traverse` mFile @@ -107,7 +106,7 @@ possiblePragmas = [name | FlagSpec{flagSpecName = T.pack -> name} <- xFlags, "St -- --------------------------------------------------------------------- -completion :: CompletionProvider +completion :: CompletionProvider IdeState completion lspFuncs _ide complParams = do let (TextDocumentIdentifier uri) = complParams ^. J.textDocument position = complParams ^. J.position diff --git a/plugins/default/src/Ide/Plugin/StylishHaskell.hs b/plugins/default/src/Ide/Plugin/StylishHaskell.hs index 3fab035b91..1733039098 100644 --- a/plugins/default/src/Ide/Plugin/StylishHaskell.hs +++ b/plugins/default/src/Ide/Plugin/StylishHaskell.hs @@ -8,7 +8,7 @@ where import Control.Monad.IO.Class import Data.Text (Text) import qualified Data.Text as T -import Ide.Plugin.Formatter +import Development.IDE (IdeState) import Ide.PluginUtils import Ide.Types import Language.Haskell.Stylish @@ -17,7 +17,7 @@ import Language.Haskell.LSP.Types as J import System.Directory import System.FilePath -descriptor :: PluginId -> PluginDescriptor +descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) { pluginFormattingProvider = Just provider } @@ -25,7 +25,7 @@ descriptor plId = (defaultPluginDescriptor plId) -- | Formatter provider of stylish-haskell. -- Formats the given source in either a given Range or the whole Document. -- If the provider fails an error is returned that can be displayed to the user. -provider :: FormattingProvider IO +provider :: FormattingProvider IdeState IO provider _lf _ideState typ contents fp _opts = do let file = fromNormalizedFilePath fp config <- liftIO $ loadConfigFrom file diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class.hs index 27dc547b0e..9ffaaa30c7 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class.hs @@ -29,7 +29,6 @@ import Development.IDE.GHC.Compat hiding (getLoc) import Development.IDE.Spans.AtPoint import qualified GHC.Generics as Generics import GhcPlugins hiding (Var, getLoc, (<>)) -import Ide.Plugin import Ide.PluginUtils import Ide.Types import Language.Haskell.GHC.ExactPrint @@ -42,13 +41,13 @@ import SrcLoc import TcEnv import TcRnMonad -descriptor :: PluginId -> PluginDescriptor +descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) { pluginCommands = commands , pluginCodeActionProvider = Just codeAction } -commands :: [PluginCommand] +commands :: [PluginCommand IdeState] commands = [ PluginCommand "addMinimalMethodPlaceholders" "add placeholders for minimal methods" addMethodPlaceholders ] @@ -61,7 +60,7 @@ data AddMinimalMethodsParams = AddMinimalMethodsParams } deriving (Show, Eq, Generics.Generic, ToJSON, FromJSON) -addMethodPlaceholders :: CommandFunction AddMinimalMethodsParams +addMethodPlaceholders :: CommandFunction IdeState AddMinimalMethodsParams addMethodPlaceholders lf state AddMinimalMethodsParams{..} = fmap (fromMaybe errorResult) . runMaybeT $ do docPath <- MaybeT . pure . uriToNormalizedFilePath $ toNormalizedUri uri pm <- MaybeT . runAction "classplugin" state $ use GetParsedModule docPath @@ -128,7 +127,7 @@ addMethodPlaceholders lf state AddMinimalMethodsParams{..} = fmap (fromMaybe err -- | -- This implementation is ad-hoc in a sense that the diagnostic detection mechanism is -- sensitive to the format of diagnostic messages from GHC. -codeAction :: CodeActionProvider +codeAction :: CodeActionProvider IdeState codeAction _ state plId docId _ context = fmap (fromMaybe errorResult) . runMaybeT $ do docPath <- MaybeT . pure . uriToNormalizedFilePath $ toNormalizedUri uri actions <- join <$> mapM (mkActions docPath) methodDiags diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs index a7cd179d85..7173b7ee41 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs @@ -17,6 +17,7 @@ module Ide.Plugin.Eval ( descriptor, ) where +import Development.IDE (IdeState) import qualified Ide.Plugin.Eval.CodeLens as CL import Ide.Types ( PluginDescriptor (..), @@ -25,7 +26,7 @@ import Ide.Types ( ) -- |Plugin descriptor -descriptor :: PluginId -> PluginDescriptor +descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) { pluginCodeLensProvider = Just CL.codeLens diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs index f69271e23e..6c50bc05c7 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs @@ -134,7 +134,6 @@ import HscTypes ( Target (Target), TargetId (TargetFile), ) -import Ide.Plugin (mkLspCommand) import Ide.Plugin.Eval.Code ( Statement, asStatements, @@ -184,6 +183,7 @@ import Ide.Plugin.Eval.Util ( response', timed, ) +import Ide.PluginUtils (mkLspCommand) import Ide.Types ( CodeLensProvider, CommandFunction, @@ -234,7 +234,7 @@ import Util (OverridingBool (Never)) {- | Code Lens provider NOTE: Invoked every time the document is modified, not just when the document is saved. -} -codeLens :: CodeLensProvider +codeLens :: CodeLensProvider IdeState codeLens lsp st plId CodeLensParams{_textDocument} = let dbg = logWith st perf = timed dbg @@ -307,7 +307,7 @@ codeLens lsp st plId CodeLensParams{_textDocument} = evalCommandName :: CommandId evalCommandName = "evalCommand" -evalCommand :: PluginCommand +evalCommand :: PluginCommand IdeState evalCommand = PluginCommand evalCommandName "evaluate" runEvalCmd -- |Specify the test section to execute @@ -317,7 +317,7 @@ data EvalParams = EvalParams } deriving (Eq, Show, Generic, FromJSON, ToJSON) -runEvalCmd :: CommandFunction EvalParams +runEvalCmd :: CommandFunction IdeState EvalParams runEvalCmd lsp st EvalParams{..} = let dbg = logWith st perf = timed dbg diff --git a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs index 0189c8387d..d52ef9c2ef 100644 --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -29,7 +29,7 @@ import Development.IDE.Core.PositionMapping import Development.IDE.GHC.Compat import Development.Shake.Classes import GHC.Generics (Generic) -import Ide.Plugin +import Ide.PluginUtils ( mkLspCommand ) import Ide.Types import Language.Haskell.LSP.Types import PrelNames (pRELUDE) @@ -44,7 +44,7 @@ importCommandId :: CommandId importCommandId = "ImportLensCommand" -- | The "main" function of a plugin -descriptor :: PluginId -> PluginDescriptor +descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) { -- This plugin provides code lenses @@ -58,7 +58,7 @@ descriptor plId = } -- | The command descriptor -importLensCommand :: PluginCommand +importLensCommand :: PluginCommand IdeState importLensCommand = PluginCommand importCommandId "Explicit import command" runImportCommand @@ -68,7 +68,7 @@ data ImportCommandParams = ImportCommandParams WorkspaceEdit deriving anyclass (FromJSON, ToJSON) -- | The actual command handler -runImportCommand :: CommandFunction ImportCommandParams +runImportCommand :: CommandFunction IdeState ImportCommandParams runImportCommand _lspFuncs _state (ImportCommandParams edit) = do -- This command simply triggers a workspace edit! return (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams edit)) @@ -83,7 +83,7 @@ runImportCommand _lspFuncs _state (ImportCommandParams edit) = do -- the provider should produce one code lens associated to the import statement: -- -- > import Data.List (intercalate, sortBy) -lensProvider :: CodeLensProvider +lensProvider :: CodeLensProvider IdeState lensProvider _lspFuncs -- LSP functions, not used state -- ghcide state, used to retrieve typechecking artifacts @@ -112,7 +112,7 @@ lensProvider -- | If there are any implicit imports, provide one code action to turn them all -- into explicit imports. -codeActionProvider :: CodeActionProvider +codeActionProvider :: CodeActionProvider IdeState codeActionProvider _lspFuncs ideState _pId docId range _context | TextDocumentIdentifier {_uri} <- docId, Just nfp <- uriToNormalizedFilePath $ toNormalizedUri _uri = diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index db618c74ff..8aa247399b 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -49,7 +49,6 @@ import Development.IDE.GHC.Compat hiding (DynFlags(..)) import Ide.Logger import Ide.Types -import Ide.Plugin import Ide.Plugin.Config import Ide.PluginUtils import Language.Haskell.HLint as Hlint @@ -65,7 +64,7 @@ import GHC.Generics (Generic) -- --------------------------------------------------------------------- -descriptor :: PluginId -> PluginDescriptor +descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) { pluginRules = rules plId , pluginCommands = @@ -236,7 +235,7 @@ getHlintSettingsRule usage = -- --------------------------------------------------------------------- -codeActionProvider :: CodeActionProvider +codeActionProvider :: CodeActionProvider IdeState codeActionProvider _lf ideState plId docId _ context = Right . LSP.List . map CACodeAction <$> getCodeActions where @@ -287,7 +286,7 @@ codeActionProvider _lf ideState plId docId _ context = Right . LSP.List . map CA -- --------------------------------------------------------------------- -applyAllCmd :: CommandFunction Uri +applyAllCmd :: CommandFunction IdeState Uri applyAllCmd lf ide uri = do let file = maybe (error $ show uri ++ " is not a file.") toNormalizedFilePath' @@ -317,7 +316,7 @@ data OneHint = OneHint , oneHintTitle :: HintTitle } deriving (Eq, Show) -applyOneCmd :: CommandFunction ApplyOneParams +applyOneCmd :: CommandFunction IdeState ApplyOneParams applyOneCmd lf ide (AOP uri pos title) = do let oneHint = OneHint pos title let file = maybe (error $ show uri ++ " is not a file.") toNormalizedFilePath' diff --git a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs index ffb3591730..0f4314b12a 100644 --- a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs +++ b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs @@ -64,7 +64,7 @@ import GhcPlugins (Outputable, nameModule_maybe, nameRdrName, occNameFS, occNameString, rdrNameOcc, unpackFS) -import Ide.Plugin +import Ide.PluginUtils import Ide.Types import Language.Haskell.LSP.Core (LspFuncs (..), ProgressCancellable (Cancellable)) import Language.Haskell.LSP.Messages (FromServerMessage (NotShowMessage)) @@ -88,7 +88,7 @@ import Control.Monad.Trans.Maybe import Development.IDE.Core.PositionMapping import qualified Data.Aeson as Aeson -descriptor :: PluginId -> PluginDescriptor +descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) { pluginCodeActionProvider = Just provider, @@ -98,7 +98,7 @@ descriptor plId = retrieCommandName :: T.Text retrieCommandName = "retrieCommand" -retrieCommand :: PluginCommand +retrieCommand :: PluginCommand IdeState retrieCommand = PluginCommand (coerce retrieCommandName) "run the refactoring" runRetrieCmd @@ -177,7 +177,7 @@ extractImports _ _ _ = [] ------------------------------------------------------------------------------- -provider :: CodeActionProvider +provider :: CodeActionProvider IdeState provider _a state plId (TextDocumentIdentifier uri) range ca = response $ do let (J.CodeActionContext _diags _monly) = ca nuri = toNormalizedUri uri diff --git a/plugins/tactics/src/Ide/Plugin/Tactic.hs b/plugins/tactics/src/Ide/Plugin/Tactic.hs index 41deaa7eb6..e250401b3e 100644 --- a/plugins/tactics/src/Ide/Plugin/Tactic.hs +++ b/plugins/tactics/src/Ide/Plugin/Tactic.hs @@ -45,7 +45,6 @@ import DynFlags (xopt) import qualified FastString import GHC.Generics (Generic) import GHC.LanguageExtensions.Type (Extension (LambdaCase)) -import Ide.Plugin (mkLspCommand) import Ide.Plugin.Tactic.Auto import Ide.Plugin.Tactic.Context import Ide.Plugin.Tactic.GHC @@ -54,6 +53,7 @@ import Ide.Plugin.Tactic.Range import Ide.Plugin.Tactic.Tactics import Ide.Plugin.Tactic.TestTypes import Ide.Plugin.Tactic.Types +import Ide.PluginUtils import Ide.TreeTransform (transform, graft, useAnnotatedSource) import Ide.Types import Language.Haskell.LSP.Core (clientCapabilities) @@ -64,7 +64,7 @@ import System.Timeout import TcRnTypes (tcg_binds) -descriptor :: PluginId -> PluginDescriptor +descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) { pluginCommands = fmap (\tc -> @@ -151,7 +151,7 @@ runIde :: IdeState -> Action a -> IO a runIde state = runAction "tactic" state -codeActionProvider :: CodeActionProvider +codeActionProvider :: CodeActionProvider IdeState codeActionProvider _conf state plId (TextDocumentIdentifier uri) range _ctx | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = fromMaybeT (Right $ List []) $ do @@ -290,7 +290,7 @@ spliceProvenance provs = overProvenance (maybe id const $ M.lookup name provs) hi -tacticCmd :: (OccName -> TacticsM ()) -> CommandFunction TacticParams +tacticCmd :: (OccName -> TacticsM ()) -> CommandFunction IdeState TacticParams tacticCmd tac lf state (TacticParams uri range var_name) | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = fromMaybeT (Right Null, Nothing) $ do diff --git a/src/Ide/Main.hs b/src/Ide/Main.hs index 652ff517c0..b70483a4e7 100644 --- a/src/Ide/Main.hs +++ b/src/Ide/Main.hs @@ -34,17 +34,18 @@ import Development.IDE.Core.Shake import Development.IDE.LSP.LanguageServer import Development.IDE.LSP.Protocol import Development.IDE.Plugin +import Development.IDE.Plugin.HLS import Development.IDE.Session (loadSession, findCradle, defaultLoadingOptions) import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location -import Development.IDE.Types.Logger +import Development.IDE.Types.Logger as G import Development.IDE.Types.Options import qualified Language.Haskell.LSP.Core as LSP import Ide.Arguments import Ide.Logger -import Ide.Plugin import Ide.Version import Ide.Plugin.Config +import Ide.PluginUtils import Ide.Types (IdePlugins, ipMap) import Language.Haskell.LSP.Messages import Language.Haskell.LSP.Types @@ -64,10 +65,10 @@ import Development.IDE.LSP.HoverDefinition as HoverDefinition -- --------------------------------------------------------------------- -ghcIdePlugins :: T.Text -> IdePlugins -> (Plugin Config, [T.Text]) +ghcIdePlugins :: T.Text -> IdePlugins IdeState -> (Plugin Config, [T.Text]) ghcIdePlugins pid ps = (asGhcIdePlugin ps, allLspCmdIds' pid ps) -defaultMain :: Arguments -> IdePlugins -> IO () +defaultMain :: Arguments -> IdePlugins IdeState -> IO () defaultMain args idePlugins = do -- WARNING: If you write to stdout before runLanguageServer -- then the language server will not work @@ -91,7 +92,20 @@ defaultMain args idePlugins = do hPutStrLn stderr hlsVer runLspMode lspArgs idePlugins -runLspMode :: LspArguments -> IdePlugins -> IO () +-- --------------------------------------------------------------------- + +hlsLogger :: G.Logger +hlsLogger = G.Logger $ \pri txt -> + case pri of + G.Telemetry -> logm (T.unpack txt) + G.Debug -> debugm (T.unpack txt) + G.Info -> logm (T.unpack txt) + G.Warning -> warningm (T.unpack txt) + G.Error -> errorm (T.unpack txt) + +-- --------------------------------------------------------------------- + +runLspMode :: LspArguments -> IdePlugins IdeState -> IO () runLspMode lspArgs@LspArguments{..} idePlugins = do LSP.setupLogger argsLogFile ["hls", "hie-bios"] $ if argsDebugOn then L.DEBUG else L.INFO @@ -105,7 +119,7 @@ runLspMode lspArgs@LspArguments{..} idePlugins = do dir <- IO.getCurrentDirectory - pid <- getPid + pid <- T.pack . show <$> getProcessID let (ps, commandIds) = ghcIdePlugins pid idePlugins plugins = Completions.plugin <> CodeAction.plugin <> From 2670510a90edbc445cc6e72781423ea1806bd24f Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Mon, 28 Dec 2020 20:38:42 +0000 Subject: [PATCH 02/10] clean up --- ghcide/src/Development/IDE/Plugin/HLS.hs | 105 ----------------------- 1 file changed, 105 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/HLS.hs b/ghcide/src/Development/IDE/Plugin/HLS.hs index d1990ebdae..258e5020b8 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS.hs @@ -193,9 +193,6 @@ executeCommandHandlers ecs = PartialHandlers $ \WithMessage{..} x -> return x{ LSP.executeCommandHandler = withResponseAndRequest RspExecuteCommand ReqApplyWorkspaceEdit (makeExecuteCommands ecs) } --- type ExecuteCommandProvider = IdeState --- -> ExecuteCommandParams --- -> IO (Either ResponseError Value, Maybe (ServerMethod, ApplyWorkspaceEditParams)) makeExecuteCommands :: [(PluginId, [PluginCommand IdeState])] -> LSP.LspFuncs Config -> ExecuteCommandProvider IdeState makeExecuteCommands ecs lf ide = wrapUnhandledExceptions $ do let @@ -233,12 +230,6 @@ makeExecuteCommands ecs lf ide = wrapUnhandledExceptions $ do Nothing -> return (Right J.Null, Nothing) J.Error _str -> return (Right J.Null, Nothing) - -- Couldn't parse the fallback command params - -- _ -> liftIO $ - -- LSP.sendErrorResponseS (LSP.sendFunc lf) - -- (J.responseId (req ^. J.id)) - -- J.InvalidParams - -- "Invalid fallbackCodeAction params" -- Just an ordinary HIE command Just (plugin, cmd) -> runPluginCommand pluginMap lf ide plugin cmd cmdParams @@ -248,77 +239,6 @@ makeExecuteCommands ecs lf ide = wrapUnhandledExceptions $ do execCmd -{- - ReqExecuteCommand req -> do - liftIO $ U.logs $ "reactor:got ExecuteCommandRequest:" ++ show req - lf <- asks lspFuncs - - let params = req ^. J.params - - parseCmdId :: T.Text -> Maybe (PluginId, CommandId) - parseCmdId x = case T.splitOn ":" x of - [plugin, command] -> Just (PluginId plugin, CommandId command) - [_, plugin, command] -> Just (PluginId plugin, CommandId command) - _ -> Nothing - - callback obj = do - liftIO $ U.logs $ "ExecuteCommand response got:r=" ++ show obj - case fromDynJSON obj :: Maybe J.WorkspaceEdit of - Just v -> do - lid <- nextLspReqId - reactorSend $ RspExecuteCommand $ Core.makeResponseMessage req (A.Object mempty) - let msg = fmServerApplyWorkspaceEditRequest lid $ J.ApplyWorkspaceEditParams v - liftIO $ U.logs $ "ExecuteCommand sending edit: " ++ show msg - reactorSend $ ReqApplyWorkspaceEdit msg - Nothing -> reactorSend $ RspExecuteCommand $ Core.makeResponseMessage req $ dynToJSON obj - - execCmd cmdId args = do - -- The parameters to the HIE command are always the first element - let cmdParams = case args of - Just (J.List (x:_)) -> x - _ -> A.Null - - case parseCmdId cmdId of - -- Shortcut for immediately applying a applyWorkspaceEdit as a fallback for v3.8 code actions - Just ("hls", "fallbackCodeAction") -> do - case A.fromJSON cmdParams of - A.Success (FallbackCodeActionParams mEdit mCmd) -> do - - -- Send off the workspace request if it has one - forM_ mEdit $ \edit -> do - lid <- nextLspReqId - let eParams = J.ApplyWorkspaceEditParams edit - eReq = fmServerApplyWorkspaceEditRequest lid eParams - reactorSend $ ReqApplyWorkspaceEdit eReq - - case mCmd of - -- If we have a command, continue to execute it - Just (J.Command _ innerCmdId innerArgs) -> execCmd innerCmdId innerArgs - - -- Otherwise we need to send back a response oureslves - Nothing -> reactorSend $ RspExecuteCommand $ Core.makeResponseMessage req (A.Object mempty) - - -- Couldn't parse the fallback command params - _ -> liftIO $ - Core.sendErrorResponseS (Core.sendFunc lf) - (J.responseId (req ^. J.id)) - J.InvalidParams - "Invalid fallbackCodeAction params" - -- Just an ordinary HIE command - Just (plugin, cmd) -> - let preq = GReq tn "plugin" Nothing Nothing (Just $ req ^. J.id) callback (toDynJSON (Nothing :: Maybe J.WorkspaceEdit)) - $ runPluginCommand plugin cmd cmdParams - in makeRequest preq - - -- Couldn't parse the command identifier - _ -> liftIO $ - Core.sendErrorResponseS (Core.sendFunc lf) - (J.responseId (req ^. J.id)) - J.InvalidParams - "Invalid command identifier" - - execCmd (params ^. J.command) (params ^. J.arguments) --} -- ----------------------------------------------------------- wrapUnhandledExceptions :: @@ -355,11 +275,6 @@ runPluginCommand m lf ide p@(PluginId p') com@(CommandId com') arg = <> "\narg = " <> T.pack (show arg)) Nothing, Nothing) J.Success a -> f lf ide a --- lsp-request: error while parsing args for typesignature.add in plugin ghcide: --- When parsing the record ExecuteCommandParams of type --- Language.Haskell.LSP.Types.DataTypesJSON.ExecuteCommandParams the key command --- was not present. - -- ----------------------------------------------------------- mkLspCommand :: PluginId -> CommandId -> T.Text -> Maybe [J.Value] -> IO Command @@ -557,26 +472,6 @@ makeCompletions sps lf ideState params@(CompletionParams (TextDocumentIdentifier [] -> return $ Left $ responseError $ T.pack $ show $ lefts mhs hs -> return $ Right $ combine hs -{- - ReqCompletion req -> do - liftIO $ U.logs $ "reactor:got CompletionRequest:" ++ show req - let (_, doc, pos) = reqParams req - - mprefix <- getPrefixAtPos doc pos - - let callback compls = do - let rspMsg = Core.makeResponseMessage req - $ J.Completions $ J.List compls - reactorSend $ RspCompletion rspMsg - case mprefix of - Nothing -> callback [] - Just prefix -> do - snippets <- Completions.WithSnippets <$> configVal completionSnippetsOn - let hreq = IReq tn "completion" (req ^. J.id) callback - $ lift $ Completions.getCompletions doc prefix snippets - makeRequest hreq --} - getPrefixAtPos :: LSP.LspFuncs Config -> Uri -> Position -> IO (Maybe VFS.PosPrefixInfo) getPrefixAtPos lf uri pos = do mvf <- (LSP.getVirtualFileFunc lf) (J.toNormalizedUri uri) From 1d2d3cbb8db47851d1f3b89791e4819e87a53456 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Mon, 28 Dec 2020 22:40:15 +0000 Subject: [PATCH 03/10] Fix the ghcide plugin to include the rules --- ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs b/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs index fc90407097..dfcc6e72ed 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs @@ -9,8 +9,9 @@ module Development.IDE.Plugin.HLS.GhcIde import Data.Aeson import Development.IDE -import Development.IDE.Plugin.Completions -import Development.IDE.Plugin.CodeAction +import Development.IDE.Plugin as Ghcide +import Development.IDE.Plugin.Completions as Completions +import Development.IDE.Plugin.CodeAction as CodeAction import Development.IDE.LSP.HoverDefinition import Development.IDE.LSP.Outline import Ide.PluginUtils @@ -28,6 +29,7 @@ descriptor plId = (defaultPluginDescriptor plId) , pluginHoverProvider = Just hover' , pluginSymbolsProvider = Just symbolsProvider , pluginCompletionProvider = Just getCompletionsLSP + , pluginRules = Ghcide.pluginRules Completions.plugin <> Ghcide.pluginRules CodeAction.plugin } -- --------------------------------------------------------------------- From 8e73b833e5aca38bddded460488ac31c08e44787 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Mon, 28 Dec 2020 20:40:15 +0000 Subject: [PATCH 04/10] clean up PartialHandlers definition The ghcide partial handlers for completions, code actions and hover are not really being used, since they get overriden by the `<> ps` append. This is due to the right-biased semantics of `PartialHandlers` --- src/Ide/Main.hs | 13 +------------ 1 file changed, 1 insertion(+), 12 deletions(-) diff --git a/src/Ide/Main.hs b/src/Ide/Main.hs index b70483a4e7..8291887b7e 100644 --- a/src/Ide/Main.hs +++ b/src/Ide/Main.hs @@ -57,14 +57,6 @@ import qualified System.Log.Logger as L import System.Time.Extra import Development.Shake (action) --- --------------------------------------------------------------------- --- ghcide partialhandlers -import Development.IDE.Plugin.CodeAction as CodeAction -import Development.IDE.Plugin.Completions as Completions -import Development.IDE.LSP.HoverDefinition as HoverDefinition - --- --------------------------------------------------------------------- - ghcIdePlugins :: T.Text -> IdePlugins IdeState -> (Plugin Config, [T.Text]) ghcIdePlugins pid ps = (asGhcIdePlugin ps, allLspCmdIds' pid ps) @@ -121,10 +113,7 @@ runLspMode lspArgs@LspArguments{..} idePlugins = do pid <- T.pack . show <$> getProcessID let - (ps, commandIds) = ghcIdePlugins pid idePlugins - plugins = Completions.plugin <> CodeAction.plugin <> - Plugin mempty HoverDefinition.setHandlersDefinition <> - ps + (plugins, commandIds) = ghcIdePlugins pid idePlugins options = def { LSP.executeCommandCommands = Just commandIds , LSP.completionTriggerCharacters = Just "." } From 731f7646e0db327cf032f59869cf23af93d80c23 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Mon, 28 Dec 2020 21:07:58 +0000 Subject: [PATCH 05/10] Move ghcide LspConfig into Ide.Plugin.Config --- ghcide/exe/Main.hs | 10 +-- ghcide/ghcide.cabal | 1 + .../session-loader/Development/IDE/Session.hs | 2 +- ghcide/src/Development/IDE/Core/FileStore.hs | 1 + .../src/Development/IDE/LSP/Notifications.hs | 1 + ghcide/src/Development/IDE/Types/Options.hs | 37 ++-------- hls-plugin-api/src/Ide/Plugin/Config.hs | 67 +++++++++++++------ 7 files changed, 61 insertions(+), 58 deletions(-) diff --git a/ghcide/exe/Main.hs b/ghcide/exe/Main.hs index 59dca21bb4..616c01b937 100644 --- a/ghcide/exe/Main.hs +++ b/ghcide/exe/Main.hs @@ -54,6 +54,8 @@ import Development.IDE (action) import Text.Printf import Development.IDE.Core.Tracing import Development.IDE.Types.Shake (Key(Key)) +import Ide.Plugin.Config +import Ide.PluginUtils (allLspCmdIds', getProcessID, pluginDescToIdePlugins) ghcideVersion :: IO String ghcideVersion = do @@ -87,9 +89,9 @@ main = do let plugins = Completions.plugin <> CodeAction.plugin <> if argsTesting then Test.plugin else mempty - onInitialConfiguration :: InitializeRequest -> Either T.Text LspConfig + onInitialConfiguration :: InitializeRequest -> Either T.Text Config onInitialConfiguration x = case x ^. params . initializationOptions of - Nothing -> Right defaultLspConfig + Nothing -> Right def Just v -> case J.fromJSON v of J.Error err -> Left $ T.pack err J.Success a -> Right a @@ -106,7 +108,7 @@ main = do t <- t hPutStrLn stderr $ "Started LSP server in " ++ showDuration t sessionLoader <- loadSession $ fromMaybe dir rootPath - config <- fromMaybe defaultLspConfig <$> getConfig + config <- fromMaybe def <$> getConfig let options = (defaultIdeOptions sessionLoader) { optReportProgress = clientSupportsProgress caps , optShakeProfiling = argsShakeProfiling @@ -159,7 +161,7 @@ main = do , optTesting = IdeTesting argsTesting , optThreads = argsThreads , optCheckParents = NeverCheck - , optCheckProject = CheckProject False + , optCheckProject = False } logLevel = if argsVerbose then minBound else Info ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) dummyWithProg (const (const id)) (logger logLevel) debouncer options vfs diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 7ea4e01df0..ec1d42774a 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -269,6 +269,7 @@ executable ghcide haskell-lsp-types, heapsize, hie-bios, + hls-plugin-api, ghcide, lens, optparse-applicative, diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 6b26610063..777cc3954b 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -136,7 +136,7 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do } <- getShakeExtras IdeOptions{ optTesting = IdeTesting optTesting - , optCheckProject = CheckProject checkProject + , optCheckProject = checkProject , optCustomDynFlags , optExtensions } <- getIdeOptions diff --git a/ghcide/src/Development/IDE/Core/FileStore.hs b/ghcide/src/Development/IDE/Core/FileStore.hs index 9069640609..f49ba759e2 100644 --- a/ghcide/src/Development/IDE/Core/FileStore.hs +++ b/ghcide/src/Development/IDE/Core/FileStore.hs @@ -40,6 +40,7 @@ import Development.IDE.Core.RuleTypes import Development.IDE.Types.Options import qualified Data.Rope.UTF16 as Rope import Development.IDE.Import.DependencyInformation +import Ide.Plugin.Config (CheckParents(..)) #ifdef mingw32_HOST_OS import qualified System.Directory as Dir diff --git a/ghcide/src/Development/IDE/LSP/Notifications.hs b/ghcide/src/Development/IDE/LSP/Notifications.hs index a0df325ffc..deeb24e303 100644 --- a/ghcide/src/Development/IDE/LSP/Notifications.hs +++ b/ghcide/src/Development/IDE/LSP/Notifications.hs @@ -33,6 +33,7 @@ import qualified Data.Text as Text import Development.IDE.Core.FileStore (setSomethingModified, setFileModified, typecheckParents) import Development.IDE.Core.FileExists (modifyFileExists, watchedGlobs) import Development.IDE.Core.OfInterest +import Ide.Plugin.Config (CheckParents(CheckOnClose)) whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO () diff --git a/ghcide/src/Development/IDE/Types/Options.hs b/ghcide/src/Development/IDE/Types/Options.hs index 7bc38e7e8e..de127d8983 100644 --- a/ghcide/src/Development/IDE/Types/Options.hs +++ b/ghcide/src/Development/IDE/Types/Options.hs @@ -21,13 +21,10 @@ module Development.IDE.Types.Options , defaultIdeOptions , IdeResult , IdeGhcSession(..) - , LspConfig(..) - , defaultLspConfig - , CheckProject(..) - , CheckParents(..) , OptHaddockParse(..) ) where +import Data.Default import Development.Shake import Development.IDE.GHC.Util import GHC hiding (parseModule, typecheckModule) @@ -36,8 +33,7 @@ import qualified Language.Haskell.LSP.Types.Capabilities as LSP import qualified Data.Text as T import Development.IDE.Types.Diagnostics import Control.DeepSeq (NFData(..)) -import Data.Aeson -import GHC.Generics +import Ide.Plugin.Config data IdeGhcSession = IdeGhcSession { loadSessionFun :: FilePath -> IO (IdeResult HscEnvEq, [FilePath]) @@ -89,7 +85,7 @@ data IdeOptions = IdeOptions -- features such as diagnostics and go-to-definition, in -- situations in which they would become unavailable because of -- the presence of type errors, holes or unbound variables. - , optCheckProject :: CheckProject + , optCheckProject :: !Bool -- ^ Whether to typecheck the entire project on load , optCheckParents :: CheckParents -- ^ When to typecheck reverse dependencies of a file @@ -106,29 +102,6 @@ data IdeOptions = IdeOptions data OptHaddockParse = HaddockParse | NoHaddockParse deriving (Eq,Ord,Show,Enum) -newtype CheckProject = CheckProject { shouldCheckProject :: Bool } - deriving stock (Eq, Ord, Show) - deriving newtype (FromJSON,ToJSON) -data CheckParents - -- Note that ordering of constructors is meaningful and must be monotonically - -- increasing in the scenarios where parents are checked - = NeverCheck - | CheckOnClose - | CheckOnSaveAndClose - | AlwaysCheck - deriving stock (Eq, Ord, Show, Generic) - deriving anyclass (FromJSON, ToJSON) - -data LspConfig - = LspConfig - { checkParents :: CheckParents - , checkProject :: CheckProject - } deriving stock (Eq, Ord, Show, Generic) - deriving anyclass (FromJSON, ToJSON) - -defaultLspConfig :: LspConfig -defaultLspConfig = LspConfig CheckOnSaveAndClose (CheckProject True) - data IdePreprocessedSource = IdePreprocessedSource { preprocWarnings :: [(GHC.SrcSpan, String)] -- ^ Warnings emitted by the preprocessor. @@ -163,8 +136,8 @@ defaultIdeOptions session = IdeOptions ,optKeywords = haskellKeywords ,optDefer = IdeDefer True ,optTesting = IdeTesting False - ,optCheckProject = checkProject defaultLspConfig - ,optCheckParents = checkParents defaultLspConfig + ,optCheckProject = checkProject def + ,optCheckParents = checkParents def ,optHaddockParse = HaddockParse ,optCustomDynFlags = id } diff --git a/hls-plugin-api/src/Ide/Plugin/Config.hs b/hls-plugin-api/src/Ide/Plugin/Config.hs index 8f05a70f64..8a2a06a895 100644 --- a/hls-plugin-api/src/Ide/Plugin/Config.hs +++ b/hls-plugin-api/src/Ide/Plugin/Config.hs @@ -1,3 +1,7 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} @@ -7,6 +11,7 @@ module Ide.Plugin.Config , getConfigFromNotification , Config(..) , PluginConfig(..) + , CheckParents(..) ) where import Control.Applicative @@ -16,6 +21,7 @@ import Data.Default import qualified Data.Text as T import Language.Haskell.LSP.Types import qualified Data.Map as Map +import GHC.Generics (Generic) -- --------------------------------------------------------------------- @@ -37,13 +43,25 @@ getInitialConfig (RequestMessage _ _ _ InitializeParams{_initializationOptions = A.Error err -> Left $ T.pack err -- --------------------------------------------------------------------- +data CheckParents + -- Note that ordering of constructors is meaningful and must be monotonically + -- increasing in the scenarios where parents are checked + = NeverCheck + | CheckOnClose + | CheckOnSaveAndClose + | AlwaysCheck + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (FromJSON, ToJSON) + -- | We (initially anyway) mirror the hie configuration, so that existing -- clients can simply switch executable and not have any nasty surprises. There -- will be surprises relating to config options being ignored, initially though. data Config = Config - { hlintOn :: !Bool + { checkParents :: CheckParents + , checkProject :: !Bool + , hlintOn :: !Bool , diagnosticsOnChange :: !Bool , maxNumberOfProblems :: !Int , diagnosticsDebounceDuration :: !Int @@ -56,7 +74,9 @@ data Config = instance Default Config where def = Config - { hlintOn = True + { checkParents = CheckOnSaveAndClose + , checkProject = True + , hlintOn = True , diagnosticsOnChange = True , maxNumberOfProblems = 100 , diagnosticsDebounceDuration = 350000 @@ -77,15 +97,17 @@ instance A.FromJSON Config where -- backwards compatibility we also accept "languageServerHaskell" s <- v .: "haskell" <|> v .: "languageServerHaskell" flip (A.withObject "Config.settings") s $ \o -> Config - <$> o .:? "hlintOn" .!= hlintOn def - <*> o .:? "diagnosticsOnChange" .!= diagnosticsOnChange def - <*> o .:? "maxNumberOfProblems" .!= maxNumberOfProblems def - <*> o .:? "diagnosticsDebounceDuration" .!= diagnosticsDebounceDuration def - <*> o .:? "liquidOn" .!= liquidOn def - <*> o .:? "completionSnippetsOn" .!= completionSnippetsOn def - <*> o .:? "formatOnImportOn" .!= formatOnImportOn def - <*> o .:? "formattingProvider" .!= formattingProvider def - <*> o .:? "plugin" .!= plugins def + <$> (o .:? "checkParents" <|> v .:? "checkParents") .!= checkParents def + <*> (o .:? "checkProject" <|> v .:? "checkProject") .!= checkProject def + <*> o .:? "hlintOn" .!= hlintOn def + <*> o .:? "diagnosticsOnChange" .!= diagnosticsOnChange def + <*> o .:? "maxNumberOfProblems" .!= maxNumberOfProblems def + <*> o .:? "diagnosticsDebounceDuration" .!= diagnosticsDebounceDuration def + <*> o .:? "liquidOn" .!= liquidOn def + <*> o .:? "completionSnippetsOn" .!= completionSnippetsOn def + <*> o .:? "formatOnImportOn" .!= formatOnImportOn def + <*> o .:? "formattingProvider" .!= formattingProvider def + <*> o .:? "plugin" .!= plugins def -- 2017-10-09 23:22:00.710515298 [ThreadId 11] - ---> {"jsonrpc":"2.0","method":"workspace/didChangeConfiguration","params":{"settings":{"haskell":{"maxNumberOfProblems":100,"hlintOn":true}}}} -- 2017-10-09 23:22:00.710667381 [ThreadId 15] - reactor:got didChangeConfiguration notification: @@ -97,17 +119,20 @@ instance A.FromJSON Config where -- ,("maxNumberOfProblems",Number 100.0)]))])}} instance A.ToJSON Config where - toJSON (Config h diag m d l c f fp p) = object [ "haskell" .= r ] + toJSON Config{..} = + object [ "haskell" .= r ] where - r = object [ "hlintOn" .= h - , "diagnosticsOnChange" .= diag - , "maxNumberOfProblems" .= m - , "diagnosticsDebounceDuration" .= d - , "liquidOn" .= l - , "completionSnippetsOn" .= c - , "formatOnImportOn" .= f - , "formattingProvider" .= fp - , "plugin" .= p + r = object [ "checkParents" .= checkParents + , "checkProject" .= checkProject + , "hlintOn" .= hlintOn + , "diagnosticsOnChange" .= diagnosticsOnChange + , "maxNumberOfProblems" .= maxNumberOfProblems + , "diagnosticsDebounceDuration" .= diagnosticsDebounceDuration + , "liquidOn" .= liquidOn + , "completionSnippetsOn" .= completionSnippetsOn + , "formatOnImportOn" .= formatOnImportOn + , "formattingProvider" .= formattingProvider + , "plugin" .= plugins ] -- --------------------------------------------------------------------- From 586b2834240a7a7e66b141f4c707cf787710405f Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Mon, 28 Dec 2020 21:10:47 +0000 Subject: [PATCH 06/10] Use HLS plugins in ghcide For now there is only one, the main ghcide plugin. But this will allow us to break it down in more fine grained plugins with parallel semantics, both for execution and error handling --- ghcide/exe/Main.hs | 15 ++++++++++----- 1 file changed, 10 insertions(+), 5 deletions(-) diff --git a/ghcide/exe/Main.hs b/ghcide/exe/Main.hs index 616c01b937..5a3adfd546 100644 --- a/ghcide/exe/Main.hs +++ b/ghcide/exe/Main.hs @@ -28,8 +28,6 @@ import Development.IDE.Types.Diagnostics import Development.IDE.Types.Options import Development.IDE.Types.Logger import Development.IDE.Plugin -import Development.IDE.Plugin.Completions as Completions -import Development.IDE.Plugin.CodeAction as CodeAction import Development.IDE.Plugin.Test as Test import Development.IDE.Session (loadSession) import qualified Language.Haskell.LSP.Core as LSP @@ -54,6 +52,8 @@ import Development.IDE (action) import Text.Printf import Development.IDE.Core.Tracing import Development.IDE.Types.Shake (Key(Key)) +import Development.IDE.Plugin.HLS (asGhcIdePlugin) +import Development.IDE.Plugin.HLS.GhcIde as GhcIde import Ide.Plugin.Config import Ide.PluginUtils (allLspCmdIds', getProcessID, pluginDescToIdePlugins) @@ -85,9 +85,14 @@ main = do whenJust argsCwd IO.setCurrentDirectory dir <- IO.getCurrentDirectory - command <- makeLspCommandId "typesignature.add" - let plugins = Completions.plugin <> CodeAction.plugin + let hlsPlugins = pluginDescToIdePlugins [GhcIde.descriptor "ghcide"] + + pid <- T.pack . show <$> getProcessID + let hlsPlugin = asGhcIdePlugin hlsPlugins + hlsCommands = allLspCmdIds' pid hlsPlugins + + let plugins = hlsPlugin <> if argsTesting then Test.plugin else mempty onInitialConfiguration :: InitializeRequest -> Either T.Text Config onInitialConfiguration x = case x ^. params . initializationOptions of @@ -96,7 +101,7 @@ main = do J.Error err -> Left $ T.pack err J.Success a -> Right a onConfigurationChange = const $ Left "Updating Not supported" - options = def { LSP.executeCommandCommands = Just [command] + options = def { LSP.executeCommandCommands = Just hlsCommands , LSP.completionTriggerCharacters = Just "." } From b3f36a252553a28885a824fc7e07f62d708a7acd Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Tue, 29 Dec 2020 10:05:35 +0000 Subject: [PATCH 07/10] Fix hlints --- ghcide/src/Development/IDE/Plugin/HLS.hs | 24 +++++++------------ .../Development/IDE/Plugin/HLS/Formatter.hs | 5 ---- ghcide/src/Development/IDE/Types/Options.hs | 7 ------ 3 files changed, 8 insertions(+), 28 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/HLS.hs b/ghcide/src/Development/IDE/Plugin/HLS.hs index 258e5020b8..2d741522e6 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS.hs @@ -1,11 +1,4 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveAnyClass #-} module Development.IDE.Plugin.HLS ( @@ -77,7 +70,7 @@ asGhcIdePlugin mp = rulesPlugins :: [(PluginId, Rules ())] -> Plugin Config rulesPlugins rs = Plugin rules mempty where - rules = mconcat $ map snd rs + rules = foldMap snd rs codeActionPlugins :: [(PluginId, CodeActionProvider IdeState)] -> Plugin Config codeActionPlugins cas = Plugin codeActionRules (codeActionHandlers cas) @@ -104,7 +97,7 @@ makeCodeAction cas lf ideState (CodeActionParams docId range context _) = do then provider lf ideState pid docId range context else return $ Right (List []) r <- mapM makeAction cas - let actions = filter wasRequested . concat $ map unL $ rights r + let actions = filter wasRequested . foldMap unL $ rights r res <- send caps actions return $ Right res where @@ -320,7 +313,7 @@ makeHover hps lf ideState params -- work out range here? let hs = catMaybes (rights mhs) r = listToMaybe $ mapMaybe (^. range) hs - h = case mconcat ((map (^. contents) hs) :: [HoverContents]) of + h = case foldMap (^. contents) hs of HoverContentsMS (List []) -> Nothing hh -> Just $ Hover hh r return $ Right h @@ -347,8 +340,7 @@ makeSymbols sps lf ideState params = do let uri' = params ^. textDocument . uri (C.ClientCapabilities _ tdc _ _) = LSP.clientCapabilities lf - supportsHierarchy = fromMaybe False $ tdc >>= C._documentSymbol - >>= C._hierarchicalDocumentSymbolSupport + supportsHierarchy = Just True == (tdc >>= C._documentSymbol >>= C._hierarchicalDocumentSymbolSupport) convertSymbols :: [DocumentSymbol] -> DSResult convertSymbols symbs | supportsHierarchy = DSDocumentSymbols $ List symbs @@ -400,7 +392,7 @@ renameWith providers lspFuncs state params = do -- TODO:AZ: we need to consider the right way to combine possible renamers results <- mapM makeAction providers case partitionEithers results of - (errors, []) -> return $ Left $ responseError $ T.pack $ show $ errors + (errors, []) -> return $ Left $ responseError $ T.pack $ show errors (_, edits) -> return $ Right $ mconcat edits -- --------------------------------------------------------------------- @@ -443,7 +435,7 @@ makeCompletions :: [(PluginId, CompletionProvider IdeState)] makeCompletions sps lf ideState params@(CompletionParams (TextDocumentIdentifier doc) pos _context _mt) = do mprefix <- getPrefixAtPos lf doc pos - _snippets <- WithSnippets <$> completionSnippetsOn <$> getClientConfig lf + _snippets <- WithSnippets . completionSnippetsOn <$> getClientConfig lf let combine :: [CompletionResponseResult] -> CompletionResponseResult @@ -474,7 +466,7 @@ makeCompletions sps lf ideState params@(CompletionParams (TextDocumentIdentifier getPrefixAtPos :: LSP.LspFuncs Config -> Uri -> Position -> IO (Maybe VFS.PosPrefixInfo) getPrefixAtPos lf uri pos = do - mvf <- (LSP.getVirtualFileFunc lf) (J.toNormalizedUri uri) + mvf <- LSP.getVirtualFileFunc lf (J.toNormalizedUri uri) case mvf of Just vf -> VFS.getCompletionPrefix pos vf Nothing -> return Nothing diff --git a/ghcide/src/Development/IDE/Plugin/HLS/Formatter.hs b/ghcide/src/Development/IDE/Plugin/HLS/Formatter.hs index c5e9185945..84fb9c47f2 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS/Formatter.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS/Formatter.hs @@ -1,8 +1,3 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} module Development.IDE.Plugin.HLS.Formatter ( diff --git a/ghcide/src/Development/IDE/Types/Options.hs b/ghcide/src/Development/IDE/Types/Options.hs index de127d8983..d0411bc7a8 100644 --- a/ghcide/src/Development/IDE/Types/Options.hs +++ b/ghcide/src/Development/IDE/Types/Options.hs @@ -1,13 +1,6 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DerivingStrategies #-} - -{- HLINT ignore "Avoid restricted extensions" -} - -- | Options module Development.IDE.Types.Options ( IdeOptions(..) From ac53ce748f295e399cc66a105d44eeacf872dbca Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Wed, 30 Dec 2020 10:10:36 +0000 Subject: [PATCH 08/10] Revert "Temporarily disable the upstream branch for benchmarks" This reverts commit 7bb3c6efae40fa9654726c1a232a6b76b1a6d63a. --- ghcide/bench/config.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/bench/config.yaml b/ghcide/bench/config.yaml index ef593adbdb..26c179ab02 100644 --- a/ghcide/bench/config.yaml +++ b/ghcide/bench/config.yaml @@ -55,5 +55,5 @@ versions: # - v0.4.0 # - v0.5.0 # - v0.6.0 -# - upstream: origin/master +- upstream: origin/master - HEAD From 4f1edbbf159610a22ffcc2ca3212c6e22d8fe10d Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Wed, 30 Dec 2020 17:12:50 +0000 Subject: [PATCH 09/10] Disable the Windows 8.6.4 test --- .github/workflows/test.yml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index f29fab2ba5..d15b81b057 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -20,6 +20,8 @@ jobs: - os: windows-latest ghc: "8.8.2" # fails due to error with Cabal include: + - os: windows-latest + ghc: "8.6.4" # times out after 300m - os: windows-latest ghc: "8.10.2.2" # only available for windows and choco # one ghc-lib build From 55893d7451ac9ac4c848a2f9163274093448cd59 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Wed, 30 Dec 2020 19:20:25 +0000 Subject: [PATCH 10/10] Fix unrelated hlints Not sure why these are triggering now. Linting should be restricted to the Diff ... --- ghcide/src/Development/IDE/Plugin/Completions/Logic.hs | 7 ++++--- ghcide/src/Development/IDE/Spans/Documentation.hs | 6 +++--- 2 files changed, 7 insertions(+), 6 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs index e6adbb310a..2d91e297ff 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs @@ -53,6 +53,7 @@ import ConLike import GhcPlugins ( flLabel, unpackFS) +import Data.Either (fromRight) -- From haskell-ide-engine/hie-plugin-api/Haskell/Ide/Engine/Context.hs @@ -337,14 +338,14 @@ cacheDataProducer packageState curMod rdrEnv limports deps = do name' <- lookupName packageState m n return $ name' >>= safeTyThingForRecord - let recordCompls = case either (const Nothing) id record_ty of + let recordCompls = case fromRight Nothing record_ty of Just (ctxStr, flds) -> case flds of [] -> [] _ -> [mkRecordSnippetCompItem ctxStr flds (ppr mn) docs imp'] Nothing -> [] - return $ [mkNameCompItem n mn (either (const Nothing) id ty) Nothing docs imp'] ++ - recordCompls + return $ mkNameCompItem n mn (fromRight Nothing ty) Nothing docs imp' + : recordCompls (unquals,quals) <- getCompls rdrElts diff --git a/ghcide/src/Development/IDE/Spans/Documentation.hs b/ghcide/src/Development/IDE/Spans/Documentation.hs index b6a8327a40..126e39d797 100644 --- a/ghcide/src/Development/IDE/Spans/Documentation.hs +++ b/ghcide/src/Development/IDE/Spans/Documentation.hs @@ -69,7 +69,7 @@ mkDocMap env sources rm this_mod = lookupKind :: HscEnv -> Module -> Name -> IO (Maybe TyThing) lookupKind env mod = - fmap (either (const Nothing) id) . catchSrcErrors (hsc_dflags env) "span" . lookupName env mod + fmap (fromRight Nothing) . catchSrcErrors (hsc_dflags env) "span" . lookupName env mod getDocumentationTryGhc :: HscEnv -> Module -> [ParsedModule] -> Name -> IO SpanDoc getDocumentationTryGhc env mod deps n = head <$> getDocumentationsTryGhc env mod deps [n] @@ -88,7 +88,7 @@ getDocumentationsTryGhc env mod sources names = do mkSpanDocText name = SpanDocText (getDocumentation sources name) <$> getUris name - + -- Get the uris to the documentation and source html pages if they exist getUris name = do let df = hsc_dflags env @@ -221,6 +221,6 @@ lookupHtmlForModule mkDocPath df m = do lookupHtmls :: DynFlags -> UnitId -> Maybe [FilePath] lookupHtmls df ui = - -- use haddockInterfaces instead of haddockHTMLs: GHC treats haddockHTMLs as URL not path + -- use haddockInterfaces instead of haddockHTMLs: GHC treats haddockHTMLs as URL not path -- and therefore doesn't expand $topdir on Windows map takeDirectory . haddockInterfaces <$> lookupPackage df ui