From a335fbf851b8c9ed6bc687796c1ab948a8f5e309 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 27 Dec 2020 08:04:13 +0000 Subject: [PATCH] Invert the dependency between hls-plugin-api and ghcide --- ghcide | 2 +- hls-plugin-api/hls-plugin-api.cabal | 13 +- hls-plugin-api/src/Ide/Logger.hs | 16 +- hls-plugin-api/src/Ide/Plugin.hs | 660 ------------------ hls-plugin-api/src/Ide/Plugin/Formatter.hs | 110 --- hls-plugin-api/src/Ide/Plugin/GhcIde.hs | 65 -- hls-plugin-api/src/Ide/Types.hs | 148 +++- .../hls-class-plugin/src/Ide/Plugin/Class.hs | 9 +- .../src/Ide/Plugin/ExplicitImports.hs | 11 +- .../hls-hlint-plugin/src/Ide/Plugin/Hlint.hs | 9 +- .../src/Ide/Plugin/Retrie.hs | 7 +- plugins/tactics/src/Ide/Plugin/Tactic.hs | 7 +- src/Ide/Main.hs | 27 +- 13 files changed, 164 insertions(+), 920 deletions(-) delete mode 100644 hls-plugin-api/src/Ide/Plugin.hs delete mode 100644 hls-plugin-api/src/Ide/Plugin/Formatter.hs delete mode 100644 hls-plugin-api/src/Ide/Plugin/GhcIde.hs diff --git a/ghcide b/ghcide index 6de5acdf4c4..a31ea1df05f 160000 --- a/ghcide +++ b/ghcide @@ -1 +1 @@ -Subproject commit 6de5acdf4c4c0d664ed6212e14614426b8adf183 +Subproject commit a31ea1df05f3d92dc5992776af7ae87a1239bd46 diff --git a/hls-plugin-api/hls-plugin-api.cabal b/hls-plugin-api/hls-plugin-api.cabal index f88f7be36ab..a860049f85f 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 bd720ffc200..1f960d86885 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.hs b/hls-plugin-api/src/Ide/Plugin.hs deleted file mode 100644 index 7913c547785..00000000000 --- a/hls-plugin-api/src/Ide/Plugin.hs +++ /dev/null @@ -1,660 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Ide.Plugin - ( - 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.LSP.Server -import GHC.Generics -import Ide.Logger -import Ide.Plugin.Config -import Ide.Plugin.Formatter -import Ide.Types -import qualified Language.Haskell.LSP.Core as LSP -import Language.Haskell.LSP.Messages -import Language.Haskell.LSP.Types -import qualified Language.Haskell.LSP.Types as J -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() - --- --------------------------------------------------------------------- - --- | 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 mp = - mkPlugin rulesPlugins (Just . pluginRules) <> - mkPlugin executeCommandPlugins (Just . pluginCommands) <> - mkPlugin codeActionPlugins pluginCodeActionProvider <> - mkPlugin codeLensPlugins pluginCodeLensProvider <> - -- Note: diagnostics are provided via Rules from pluginDiagnosticProvider - mkPlugin hoverPlugins pluginHoverProvider <> - mkPlugin symbolsPlugins pluginSymbolsProvider <> - mkPlugin formatterPlugins pluginFormattingProvider <> - mkPlugin completionsPlugins pluginCompletionProvider <> - mkPlugin renamePlugins pluginRenameProvider - where - justs (p, Just x) = [(p, x)] - justs (_, Nothing) = [] - - ls = Map.toList (ipMap mp) - - mkPlugin :: ([(PluginId, b)] -> Plugin Config) -> (PluginDescriptor -> 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 - -- create the plugin – otherwise we we end up declaring handlers for - -- capabilities that there are no plugins for - [] -> 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 - -codeActionPlugins :: [(PluginId, CodeActionProvider)] -> Plugin Config -codeActionPlugins cas = Plugin codeActionRules (codeActionHandlers cas) - -codeActionRules :: Rules () -codeActionRules = mempty - -codeActionHandlers :: [(PluginId, CodeActionProvider)] -> PartialHandlers Config -codeActionHandlers cas = PartialHandlers $ \WithMessage{..} x -> return x - { LSP.codeActionHandler - = withResponse RspCodeAction (makeCodeAction cas) - } - -makeCodeAction :: [(PluginId, CodeActionProvider)] - -> LSP.LspFuncs Config -> IdeState - -> CodeActionParams - -> IO (Either ResponseError (List CAResult)) -makeCodeAction cas lf ideState (CodeActionParams docId range context _) = do - let caps = LSP.clientCapabilities lf - unL (List ls) = ls - makeAction (pid,provider) = do - pluginConfig <- getPluginConfig lf pid - if pluginEnabled pluginConfig plcCodeActionsOn - 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 - res <- send caps actions - return $ Right res - where - wasRequested :: CAResult -> Bool - wasRequested (CACommand _) = True - wasRequested (CACodeAction ca) - | Nothing <- only context = True - | Just (List allowed) <- only context - , Just caKind <- ca ^. kind = caKind `elem` allowed - | otherwise = False - - wrapCodeAction :: C.ClientCapabilities -> CAResult -> IO (Maybe CAResult) - wrapCodeAction _ (CACommand cmd) = return $ Just (CACommand cmd) - wrapCodeAction caps (CACodeAction action) = do - - let (C.ClientCapabilities _ textDocCaps _ _) = caps - let literalSupport = textDocCaps >>= C._codeAction >>= C._codeActionLiteralSupport - - case literalSupport of - Nothing -> do - let cmdParams = [J.toJSON (FallbackCodeActionParams (action ^. edit) (action ^. command))] - cmd <- mkLspCommand "hls" "fallbackCodeAction" (action ^. title) (Just cmdParams) - return $ Just (CACommand cmd) - Just _ -> return $ Just (CACodeAction action) - - send :: C.ClientCapabilities -> [CAResult] -> IO (List CAResult) - send caps codeActions = List . catMaybes <$> mapM (wrapCodeAction caps) codeActions - -data FallbackCodeActionParams = - FallbackCodeActionParams - { fallbackWorkspaceEdit :: Maybe WorkspaceEdit - , fallbackCommand :: Maybe Command - } - deriving (Generic, J.ToJSON, J.FromJSON) - --- ----------------------------------------------------------- - -codeLensPlugins :: [(PluginId, CodeLensProvider)] -> Plugin Config -codeLensPlugins cas = Plugin codeLensRules (codeLensHandlers cas) - -codeLensRules :: Rules () -codeLensRules = mempty - -codeLensHandlers :: [(PluginId, CodeLensProvider)] -> PartialHandlers Config -codeLensHandlers cas = PartialHandlers $ \WithMessage{..} x -> return x - { LSP.codeLensHandler - = withResponse RspCodeLens (makeCodeLens cas) - } - -makeCodeLens :: [(PluginId, CodeLensProvider)] - -> LSP.LspFuncs Config - -> IdeState - -> CodeLensParams - -> IO (Either ResponseError (List CodeLens)) -makeCodeLens cas lf ideState params = do - logInfo (ideLogger ideState) "Plugin.makeCodeLens (ideLogger)" -- AZ - let - makeLens (pid, provider) = do - pluginConfig <- getPluginConfig lf pid - r <- if pluginEnabled pluginConfig plcCodeLensOn - then provider lf ideState pid params - else return $ Right (List []) - return (pid, r) - breakdown :: [(PluginId, Either ResponseError a)] -> ([(PluginId, ResponseError)], [(PluginId, a)]) - breakdown ls = (concatMap doOneLeft ls, concatMap doOneRight ls) - where - doOneLeft (pid, Left err) = [(pid,err)] - doOneLeft (_, Right _) = [] - - doOneRight (pid, Right a) = [(pid,a)] - doOneRight (_, Left _) = [] - - r <- mapM makeLens cas - case breakdown r of - ([],[]) -> return $ Right $ List [] - (es,[]) -> return $ Left $ ResponseError InternalError (T.pack $ "codeLens failed:" ++ show es) Nothing - (_,rs) -> return $ Right $ List (concatMap (\(_,List cs) -> cs) rs) - --- ----------------------------------------------------------- - -executeCommandPlugins :: [(PluginId, [PluginCommand])] -> Plugin Config -executeCommandPlugins ecs = Plugin mempty (executeCommandHandlers ecs) - -executeCommandHandlers :: [(PluginId, [PluginCommand])] -> 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 ecs lf ide = wrapUnhandledExceptions $ do - let - pluginMap = Map.fromList ecs - 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 - - execCmd :: ExecuteCommandParams -> IO (Either ResponseError J.Value, Maybe (ServerMethod, ApplyWorkspaceEditParams)) - execCmd (ExecuteCommandParams cmdId args _) = do - -- The parameters to the HIE command are always the first element - let cmdParams :: J.Value - cmdParams = case args of - Just (J.List (x:_)) -> x - _ -> J.Null - - case parseCmdId cmdId of - -- Shortcut for immediately applying a applyWorkspaceEdit as a fallback for v3.8 code actions - Just ("hls", "fallbackCodeAction") -> - case J.fromJSON cmdParams of - J.Success (FallbackCodeActionParams mEdit mCmd) -> do - - -- Send off the workspace request if it has one - forM_ mEdit $ \edit -> do - let eParams = J.ApplyWorkspaceEditParams edit - reqId <- LSP.getNextReqId lf - LSP.sendFunc lf $ ReqApplyWorkspaceEdit $ RequestMessage "2.0" reqId WorkspaceApplyEdit eParams - - case mCmd of - -- If we have a command, continue to execute it - Just (J.Command _ innerCmdId innerArgs) - -> execCmd (ExecuteCommandParams innerCmdId innerArgs Nothing) - 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 - - -- Couldn't parse the command identifier - _ -> return (Left $ ResponseError InvalidParams "Invalid command identifier" Nothing, Nothing) - - 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 :: - (a -> IO (Either ResponseError J.Value, Maybe b)) -> - a -> IO (Either ResponseError J.Value, Maybe b) -wrapUnhandledExceptions action input = - catch (action input) $ \(e::SomeException) -> do - let resp = ResponseError InternalError (T.pack $ show e) Nothing - return (Left resp, Nothing) - - --- | Runs a plugin command given a PluginId, CommandId and --- arguments in the form of a JSON object. -runPluginCommand :: Map.Map PluginId [PluginCommand] - -> LSP.LspFuncs Config - -> IdeState - -> PluginId - -> CommandId - -> J.Value - -> IO (Either ResponseError J.Value, - Maybe (ServerMethod, ApplyWorkspaceEditParams)) -runPluginCommand m lf ide p@(PluginId p') com@(CommandId com') arg = - case Map.lookup p m of - Nothing -> return - (Left $ ResponseError InvalidRequest ("Plugin " <> p' <> " doesn't exist") Nothing, Nothing) - Just xs -> case List.find ((com ==) . commandId) xs of - Nothing -> return (Left $ - ResponseError InvalidRequest ("Command " <> com' <> " isn't defined for plugin " <> p' - <> ". Legal commands are: " <> T.pack(show $ map commandId xs)) Nothing, Nothing) - Just (PluginCommand _ _ f) -> case J.fromJSON arg of - J.Error err -> return (Left $ - ResponseError InvalidParams ("error while parsing args for " <> com' <> " in plugin " <> p' - <> ": " <> T.pack err - <> "\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 - 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 - -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 hs = Plugin hoverRules (hoverHandlers hs) - -hoverRules :: Rules () -hoverRules = mempty - -hoverHandlers :: [(PluginId, HoverProvider)] -> PartialHandlers Config -hoverHandlers hps = PartialHandlers $ \WithMessage{..} x -> - return x{LSP.hoverHandler = withResponse RspHover (makeHover hps)} - -makeHover :: [(PluginId, HoverProvider)] - -> LSP.LspFuncs Config -> IdeState - -> TextDocumentPositionParams - -> IO (Either ResponseError (Maybe Hover)) -makeHover hps lf ideState params - = do - let - makeHover(pid,p) = do - pluginConfig <- getPluginConfig lf pid - if pluginEnabled pluginConfig plcHoverOn - then p ideState params - else return $ Right Nothing - mhs <- mapM makeHover hps - -- TODO: We should support ServerCapabilities and declare that - -- we don't support hover requests during initialization if we - -- don't have any hover providers - -- TODO: maybe only have provider give MarkedString and - -- work out range here? - let hs = catMaybes (rights mhs) - r = listToMaybe $ mapMaybe (^. range) hs - h = case mconcat ((map (^. contents) hs) :: [HoverContents]) of - HoverContentsMS (List []) -> Nothing - hh -> Just $ Hover hh r - return $ Right h - --- --------------------------------------------------------------------- --- --------------------------------------------------------------------- - -symbolsPlugins :: [(PluginId, SymbolsProvider)] -> Plugin Config -symbolsPlugins hs = Plugin symbolsRules (symbolsHandlers hs) - -symbolsRules :: Rules () -symbolsRules = mempty - -symbolsHandlers :: [(PluginId, SymbolsProvider)] -> PartialHandlers Config -symbolsHandlers hps = PartialHandlers $ \WithMessage{..} x -> - return x {LSP.documentSymbolHandler = withResponse RspDocumentSymbols (makeSymbols hps)} - -makeSymbols :: [(PluginId, SymbolsProvider)] - -> LSP.LspFuncs Config - -> IdeState - -> DocumentSymbolParams - -> IO (Either ResponseError DSResult) -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 - convertSymbols :: [DocumentSymbol] -> DSResult - convertSymbols symbs - | supportsHierarchy = DSDocumentSymbols $ List symbs - | otherwise = DSSymbolInformation (List $ concatMap (go Nothing) symbs) - where - go :: Maybe T.Text -> DocumentSymbol -> [SymbolInformation] - go parent ds = - let children' :: [SymbolInformation] - children' = concatMap (go (Just name')) (fromMaybe mempty (ds ^. children)) - loc = Location uri' (ds ^. range) - name' = ds ^. name - si = SymbolInformation name' (ds ^. kind) (ds ^. deprecated) loc parent - in [si] <> children' - - makeSymbols (pid,p) = do - pluginConfig <- getPluginConfig lf pid - if pluginEnabled pluginConfig plcSymbolsOn - then p lf ideState params - else return $ Right [] - mhs <- mapM makeSymbols sps - case rights mhs of - [] -> return $ Left $ responseError $ T.pack $ show $ lefts mhs - hs -> return $ Right $ convertSymbols $ concat hs - - --- --------------------------------------------------------------------- --- --------------------------------------------------------------------- - -renamePlugins :: [(PluginId, RenameProvider)] -> Plugin Config -renamePlugins providers = Plugin rules handlers - where - rules = mempty - handlers = PartialHandlers $ \WithMessage{..} x -> return x - { LSP.renameHandler = withResponse RspRename (renameWith providers)} - -renameWith :: - [(PluginId, RenameProvider)] -> - LSP.LspFuncs Config -> - IdeState -> - RenameParams -> - IO (Either ResponseError WorkspaceEdit) -renameWith providers lspFuncs state params = do - let - makeAction (pid,p) = do - pluginConfig <- getPluginConfig lspFuncs pid - if pluginEnabled pluginConfig plcRenameOn - then p lspFuncs state params - else return $ Right $ WorkspaceEdit Nothing Nothing - -- 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 - (_, edits) -> return $ Right $ mconcat edits - --- --------------------------------------------------------------------- --- --------------------------------------------------------------------- - -formatterPlugins :: [(PluginId, FormattingProvider IO)] -> Plugin Config -formatterPlugins providers - = Plugin formatterRules - (formatterHandlers (Map.fromList (("none",noneProvider):providers))) - -formatterRules :: Rules () -formatterRules = mempty - -formatterHandlers :: Map.Map PluginId (FormattingProvider IO) -> PartialHandlers Config -formatterHandlers providers = PartialHandlers $ \WithMessage{..} x -> return x - { LSP.documentFormattingHandler - = withResponse RspDocumentFormatting (formatting providers) - , LSP.documentRangeFormattingHandler - = withResponse RspDocumentRangeFormatting (rangeFormatting providers) - } - --- --------------------------------------------------------------------- --- --------------------------------------------------------------------- - -completionsPlugins :: [(PluginId, CompletionProvider)] -> Plugin Config -completionsPlugins cs = Plugin completionsRules (completionsHandlers cs) - -completionsRules :: Rules () -completionsRules = mempty - -completionsHandlers :: [(PluginId, CompletionProvider)] -> PartialHandlers Config -completionsHandlers cps = PartialHandlers $ \WithMessage{..} x -> - return x {LSP.completionHandler = withResponse RspCompletion (makeCompletions cps)} - -makeCompletions :: [(PluginId, CompletionProvider)] - -> LSP.LspFuncs Config - -> IdeState - -> CompletionParams - -> IO (Either ResponseError CompletionResponseResult) -makeCompletions sps lf ideState params@(CompletionParams (TextDocumentIdentifier doc) pos _context _mt) - = do - mprefix <- getPrefixAtPos lf doc pos - _snippets <- WithSnippets <$> completionSnippetsOn <$> getClientConfig lf - - let - combine :: [CompletionResponseResult] -> CompletionResponseResult - combine cs = go (Completions $ List []) cs - where - go acc [] = acc - go (Completions (List ls)) (Completions (List ls2):rest) - = go (Completions (List (ls <> ls2))) rest - go (Completions (List ls)) (CompletionList (CompletionListType complete (List ls2)):rest) - = go (CompletionList $ CompletionListType complete (List (ls <> ls2))) rest - go (CompletionList (CompletionListType complete (List ls))) (CompletionList (CompletionListType complete2 (List ls2)):rest) - = go (CompletionList $ CompletionListType (complete || complete2) (List (ls <> ls2))) rest - go (CompletionList (CompletionListType complete (List ls))) (Completions (List ls2):rest) - = go (CompletionList $ CompletionListType complete (List (ls <> ls2))) rest - makeAction (pid,p) = do - pluginConfig <- getPluginConfig lf pid - if pluginEnabled pluginConfig plcCompletionOn - then p lf ideState params - else return $ Right $ Completions $ List [] - - case mprefix of - Nothing -> return $ Right $ Completions $ List [] - Just _prefix -> do - mhs <- mapM makeAction sps - case rights mhs of - [] -> 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) - 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/hls-plugin-api/src/Ide/Plugin/Formatter.hs deleted file mode 100644 index ba78c24c9cc..00000000000 --- a/hls-plugin-api/src/Ide/Plugin/Formatter.hs +++ /dev/null @@ -1,110 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} - -module Ide.Plugin.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.Types -import Ide.Plugin.Config -import qualified Language.Haskell.LSP.Core as LSP -import Language.Haskell.LSP.Types -import Text.Regex.TDFA.Text() - --- --------------------------------------------------------------------- - -formatting :: Map.Map PluginId (FormattingProvider IO) - -> LSP.LspFuncs Config -> IdeState -> DocumentFormattingParams - -> IO (Either ResponseError (List TextEdit)) -formatting providers lf ideState - (DocumentFormattingParams (TextDocumentIdentifier uri) params _mprogress) - = doFormatting lf providers ideState FormatText uri params - --- --------------------------------------------------------------------- - -rangeFormatting :: Map.Map PluginId (FormattingProvider IO) - -> LSP.LspFuncs Config -> IdeState -> DocumentRangeFormattingParams - -> IO (Either ResponseError (List TextEdit)) -rangeFormatting providers lf ideState - (DocumentRangeFormattingParams (TextDocumentIdentifier uri) range params _mprogress) - = doFormatting lf providers ideState (FormatRange range) uri params - --- --------------------------------------------------------------------- - -doFormatting :: LSP.LspFuncs Config -> Map.Map PluginId (FormattingProvider IO) - -> IdeState -> FormattingType -> Uri -> FormattingOptions - -> IO (Either ResponseError (List TextEdit)) -doFormatting lf providers ideState ft uri params = do - mc <- LSP.config lf - let mf = maybe "none" formattingProvider mc - case Map.lookup (PluginId mf) providers of - Just provider -> - case uriToFilePath uri of - Just (toNormalizedFilePath -> fp) -> do - (_, mb_contents) <- runAction "Formatter" ideState $ getFileContents fp - case mb_contents of - Just contents -> do - logDebug (ideLogger ideState) $ T.pack $ - "Formatter.doFormatting: contents=" ++ show contents -- AZ - provider lf ideState ft contents fp params - Nothing -> return $ Left $ responseError $ T.pack $ "Formatter plugin: could not get file contents for " ++ show uri - Nothing -> return $ Left $ responseError $ T.pack $ "Formatter plugin: uriToFilePath failed for: " ++ show uri - Nothing -> return $ Left $ responseError $ mconcat - [ "Formatter plugin: no formatter found for:[" - , mf - , "]" - , if mf == "brittany" - then T.unlines - [ "\nThe haskell-language-server must be compiled with the agpl flag to provide Brittany." - , "Stack users add 'agpl: true' in the flags section of the 'stack.yaml' file." - , "The 'haskell-language-server.cabal' file already has this flag enabled by default." - , "For more information see: https://github.com/haskell/haskell-language-server/issues/269" - ] - 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/hls-plugin-api/src/Ide/Plugin/GhcIde.hs deleted file mode 100644 index 9690c0a8893..00000000000 --- a/hls-plugin-api/src/Ide/Plugin/GhcIde.hs +++ /dev/null @@ -1,65 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE OverloadedStrings #-} -module Ide.Plugin.GhcIde - ( - descriptor - ) where - -import Data.Aeson -import Development.IDE -import Development.IDE.Plugin.Completions -import Development.IDE.Plugin.CodeAction -import Development.IDE.LSP.HoverDefinition -import Development.IDE.LSP.Outline -import Ide.Plugin -import Ide.Types -import Language.Haskell.LSP.Types -import Text.Regex.TDFA.Text() - --- --------------------------------------------------------------------- - -descriptor :: PluginId -> PluginDescriptor -descriptor plId = (defaultPluginDescriptor plId) - { pluginCommands = [PluginCommand (CommandId "typesignature.add") "adds a signature" commandAddSignature] - , pluginCodeActionProvider = Just codeAction' - , pluginCodeLensProvider = Just codeLens' - , pluginHoverProvider = Just hover' - , pluginSymbolsProvider = Just symbolsProvider - , pluginCompletionProvider = Just getCompletionsLSP - } - --- --------------------------------------------------------------------- - -hover' :: HoverProvider -hover' ideState params = do - logInfo (ideLogger ideState) "GhcIde.hover entered (ideLogger)" -- AZ - hover ideState params - --- --------------------------------------------------------------------- - -commandAddSignature :: CommandFunction WorkspaceEdit -commandAddSignature lf ide params - = commandHandler lf ide (ExecuteCommandParams "typesignature.add" (Just (List [toJSON params])) Nothing) - --- --------------------------------------------------------------------- - -codeAction' :: CodeActionProvider -codeAction' lf ide _ doc range context = fmap List <$> codeAction lf ide doc range context - --- --------------------------------------------------------------------- - -codeLens' :: CodeLensProvider -codeLens' lf ide _ params = codeLens lf ide params - --- --------------------------------------------------------------------- - -symbolsProvider :: SymbolsProvider -symbolsProvider ls ide params = do - ds <- moduleOutline ls ide params - case ds of - Right (DSDocumentSymbols (List ls)) -> return $ Right ls - Right (DSSymbolInformation (List _si)) -> - return $ Left $ responseError "GhcIde.symbolsProvider: DSSymbolInformation deprecated" - Left err -> return $ Left err - --- --------------------------------------------------------------------- diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index 071b9572cb0..cac395b3753 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -10,11 +11,15 @@ module Ide.Types , PluginCommand(..) , PluginId(..) , CommandId(..) + , mkLspCmdId + , mkLspCommand + , responseError , DiagnosticProvider(..) , DiagnosticProviderFunc(..) , SymbolsProvider , FormattingType(..) , FormattingProvider + , noneProvider , HoverProvider , CodeActionProvider , CodeLensProvider @@ -23,44 +28,57 @@ module Ide.Types , CompletionProvider , RenameProvider , WithSnippets(..) + , getProcessID + , getClientConfig + , getPluginConfig + , configForPlugin + , pluginEnabled ) where import Data.Aeson hiding (defaultOptions) +import qualified Data.Default import qualified Data.Map as Map +import Data.Maybe (fromMaybe) 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 import Text.Regex.TDFA.Text() +import qualified Data.Aeson.Types as J + +#ifdef mingw32_HOST_OS +import qualified System.Win32.Process as P (getCurrentProcessId) +#else +import qualified System.Posix.Process as P (getProcessID) +#endif -- --------------------------------------------------------------------- -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 +112,67 @@ 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 } +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 + + -- --------------------------------------------------------------------- -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 +201,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 +235,54 @@ 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 []) + -- --------------------------------------------------------------------- + +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 diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class.hs index 27dc547b0ef..9ffaaa30c7f 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-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs index 0189c8387d5..60419d5b364 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,6 @@ import Development.IDE.Core.PositionMapping import Development.IDE.GHC.Compat import Development.Shake.Classes import GHC.Generics (Generic) -import Ide.Plugin import Ide.Types import Language.Haskell.LSP.Types import PrelNames (pRELUDE) @@ -44,7 +43,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 +57,7 @@ descriptor plId = } -- | The command descriptor -importLensCommand :: PluginCommand +importLensCommand :: PluginCommand IdeState importLensCommand = PluginCommand importCommandId "Explicit import command" runImportCommand @@ -68,7 +67,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 +82,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 +111,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 db618c74ffd..8aa247399ba 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 ffb35917303..63ccdbee64e 100644 --- a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs +++ b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs @@ -64,7 +64,6 @@ import GhcPlugins (Outputable, nameModule_maybe, nameRdrName, occNameFS, occNameString, rdrNameOcc, unpackFS) -import Ide.Plugin import Ide.Types import Language.Haskell.LSP.Core (LspFuncs (..), ProgressCancellable (Cancellable)) import Language.Haskell.LSP.Messages (FromServerMessage (NotShowMessage)) @@ -88,7 +87,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 +97,7 @@ descriptor plId = retrieCommandName :: T.Text retrieCommandName = "retrieCommand" -retrieCommand :: PluginCommand +retrieCommand :: PluginCommand IdeState retrieCommand = PluginCommand (coerce retrieCommandName) "run the refactoring" runRetrieCmd @@ -177,7 +176,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 41deaa7eb64..b57fd133517 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 @@ -64,7 +63,7 @@ import System.Timeout import TcRnTypes (tcg_binds) -descriptor :: PluginId -> PluginDescriptor +descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) { pluginCommands = fmap (\tc -> @@ -151,7 +150,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 +289,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 652ff517c0f..7d7c8e93442 100644 --- a/src/Ide/Main.hs +++ b/src/Ide/Main.hs @@ -34,18 +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.Types (IdePlugins, ipMap) +import Ide.Types (getProcessID, IdePlugins, ipMap) import Language.Haskell.LSP.Messages import Language.Haskell.LSP.Types import qualified System.Directory.Extra as IO @@ -64,10 +64,10 @@ import Development.IDE.LSP.HoverDefinition as HoverDefinition -- --------------------------------------------------------------------- -ghcIdePlugins :: T.Text -> IdePlugins -> (Plugin Config, [T.Text]) +ghcIdePlugins :: T.Text -> IdePlugins IdeState -> (Plugin Config, [T.Text]) ghcIdePlugins pid ps = (asGhcIdePlugin ps, allLspCmdIds' pid ps) -defaultMain :: Arguments -> IdePlugins -> IO () +defaultMain :: Arguments -> IdePlugins IdeState -> IO () defaultMain args idePlugins = do -- WARNING: If you write to stdout before runLanguageServer -- then the language server will not work @@ -91,7 +91,20 @@ defaultMain args idePlugins = do hPutStrLn stderr hlsVer runLspMode lspArgs idePlugins -runLspMode :: LspArguments -> IdePlugins -> IO () +-- --------------------------------------------------------------------- + +hlsLogger :: G.Logger +hlsLogger = G.Logger $ \pri txt -> + case pri of + G.Telemetry -> logm (T.unpack txt) + G.Debug -> debugm (T.unpack txt) + G.Info -> logm (T.unpack txt) + G.Warning -> warningm (T.unpack txt) + G.Error -> errorm (T.unpack txt) + +-- --------------------------------------------------------------------- + +runLspMode :: LspArguments -> IdePlugins IdeState -> IO () runLspMode lspArgs@LspArguments{..} idePlugins = do LSP.setupLogger argsLogFile ["hls", "hie-bios"] $ if argsDebugOn then L.DEBUG else L.INFO @@ -105,7 +118,7 @@ runLspMode lspArgs@LspArguments{..} idePlugins = do dir <- IO.getCurrentDirectory - pid <- getPid + pid <- T.pack . show <$> getProcessID let (ps, commandIds) = ghcIdePlugins pid idePlugins plugins = Completions.plugin <> CodeAction.plugin <>