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 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/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 diff --git a/ghcide/exe/Main.hs b/ghcide/exe/Main.hs index 59dca21bb4..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,10 @@ 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) ghcideVersion :: IO String ghcideVersion = do @@ -83,18 +85,23 @@ 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 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 onConfigurationChange = const $ Left "Updating Not supported" - options = def { LSP.executeCommandCommands = Just [command] + options = def { LSP.executeCommandCommands = Just hlsCommands , LSP.completionTriggerCharacters = Just "." } @@ -106,7 +113,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 +166,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 b0d99e7188..ec1d42774a 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 @@ -265,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.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/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/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/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/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/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/hls-plugin-api/src/Ide/Plugin.hs b/ghcide/src/Development/IDE/Plugin/HLS.hs similarity index 62% rename from hls-plugin-api/src/Ide/Plugin.hs rename to ghcide/src/Development/IDE/Plugin/HLS.hs index 7913c54778..2d741522e6 100644 --- a/hls-plugin-api/src/Ide/Plugin.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS.hs @@ -1,47 +1,26 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Ide.Plugin +{-# LANGUAGE DeriveAnyClass #-} + +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 +29,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 +56,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,41 +65,26 @@ 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 rulesPlugins rs = Plugin rules mempty where - rules = mconcat $ map snd rs + rules = foldMap 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)) @@ -130,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 @@ -168,19 +135,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,18 +178,15 @@ 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) } --- 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 @@ -259,12 +223,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 @@ -274,77 +232,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 :: @@ -358,7 +245,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 @@ -381,16 +268,11 @@ 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 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 +281,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)) @@ -436,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 @@ -444,17 +321,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 @@ -463,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 @@ -493,7 +369,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 +377,7 @@ renamePlugins providers = Plugin rules handlers { LSP.renameHandler = withResponse RspRename (renameWith providers)} renameWith :: - [(PluginId, RenameProvider)] -> + [(PluginId, RenameProvider IdeState)] -> LSP.LspFuncs Config -> IdeState -> RenameParams -> @@ -516,13 +392,13 @@ 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 -- --------------------------------------------------------------------- -- --------------------------------------------------------------------- -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 +406,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 +417,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 @@ -559,7 +435,7 @@ makeCompletions :: [(PluginId, CompletionProvider)] 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 @@ -588,73 +464,9 @@ 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) + mvf <- LSP.getVirtualFileFunc lf (J.toNormalizedUri uri) 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 63% rename from hls-plugin-api/src/Ide/Plugin/Formatter.hs rename to ghcide/src/Development/IDE/Plugin/HLS/Formatter.hs index ba78c24c9c..84fb9c47f2 100644 --- a/hls-plugin-api/src/Ide/Plugin/Formatter.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS/Formatter.hs @@ -1,23 +1,15 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# 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 +18,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 +27,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 +36,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 +68,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 75% rename from hls-plugin-api/src/Ide/Plugin/GhcIde.hs rename to ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs index 9690c0a889..dfcc6e72ed 100644 --- a/hls-plugin-api/src/Ide/Plugin/GhcIde.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs @@ -1,24 +1,27 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE OverloadedStrings #-} -module Ide.Plugin.GhcIde + +-- | Exposes the ghcide features as an HLS plugin +module Development.IDE.Plugin.HLS.GhcIde ( descriptor ) where 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.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' @@ -26,34 +29,35 @@ descriptor plId = (defaultPluginDescriptor plId) , pluginHoverProvider = Just hover' , pluginSymbolsProvider = Just symbolsProvider , pluginCompletionProvider = Just getCompletionsLSP + , pluginRules = Ghcide.pluginRules Completions.plugin <> Ghcide.pluginRules CodeAction.plugin } -- --------------------------------------------------------------------- -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/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 diff --git a/ghcide/src/Development/IDE/Types/Options.hs b/ghcide/src/Development/IDE/Types/Options.hs index 7bc38e7e8e..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(..) @@ -21,13 +14,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 +26,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 +78,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 +95,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 +129,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/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/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 ] -- --------------------------------------------------------------------- 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..8291887b7e 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 @@ -56,18 +57,10 @@ 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 -> (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 +84,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,12 +111,9 @@ 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 <> - Plugin mempty HoverDefinition.setHandlersDefinition <> - ps + (plugins, commandIds) = ghcIdePlugins pid idePlugins options = def { LSP.executeCommandCommands = Just commandIds , LSP.completionTriggerCharacters = Just "." }