diff --git a/ghcide.cabal b/ghcide.cabal index 8ff10203b..26341e573 100644 --- a/ghcide.cabal +++ b/ghcide.cabal @@ -55,6 +55,8 @@ library haskell-lsp-types == 0.22.*, haskell-lsp == 0.22.*, hie-compat, + hls-plugin-api, + lens, mtl, network-uri, parallel, @@ -126,7 +128,6 @@ library include exposed-modules: Development.IDE - Development.IDE.Compat Development.IDE.Core.Debouncer Development.IDE.Core.FileStore Development.IDE.Core.IdeConfiguration @@ -161,6 +162,9 @@ library Development.IDE.Plugin Development.IDE.Plugin.Completions Development.IDE.Plugin.CodeAction + Development.IDE.Plugin.Formatter + Development.IDE.Plugin.GhcIde + Development.IDE.Plugin.HLS Development.IDE.Plugin.Test -- Unfortunately, we cannot use loadSession with ghc-lib since hie-bios uses diff --git a/src/Development/IDE.hs b/src/Development/IDE.hs index 91cec08d6..7a6293f90 100644 --- a/src/Development/IDE.hs +++ b/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/src/Development/IDE/Compat.hs b/src/Development/IDE/Compat.hs deleted file mode 100644 index 30c8b7d88..000000000 --- a/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/src/Development/IDE/Core/IdeConfiguration.hs b/src/Development/IDE/Core/IdeConfiguration.hs index d42322556..a9bfe088a 100644 --- a/src/Development/IDE/Core/IdeConfiguration.hs +++ b/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/src/Development/IDE/Core/Rules.hs b/src/Development/IDE/Core/Rules.hs index d2ddb537b..08ee5739f 100644 --- a/src/Development/IDE/Core/Rules.hs +++ b/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 @@ -886,6 +889,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/src/Development/IDE/Plugin.hs b/src/Development/IDE/Plugin.hs index e232e3f20..a7094ac15 100644 --- a/src/Development/IDE/Plugin.hs +++ b/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/src/Development/IDE/Plugin/CodeAction.hs b/src/Development/IDE/Plugin/CodeAction.hs index b17b35042..836a3c02d 100644 --- a/src/Development/IDE/Plugin/CodeAction.hs +++ b/src/Development/IDE/Plugin/CodeAction.hs @@ -648,7 +648,7 @@ suggestExtendImport exportsMap contents Diagnostic{_range=_range,..} | Just (binding, mod_srcspan) <- matchRegExMultipleImports _message , Just c <- contents - = mod_srcspan >>= (\(x, y) -> suggestions c binding x y) + = mod_srcspan >>= (\(x, y) -> suggestions c binding x y) | otherwise = [] where suggestions c binding mod srcspan @@ -664,7 +664,7 @@ suggestExtendImport exportsMap contents Diagnostic{_range=_range,..} renderImport IdentInfo {parent, rendered} | Just p <- parent = p <> "(" <> rendered <> ")" | otherwise = rendered - lookupExportMap binding mod + lookupExportMap binding mod | Just match <- Map.lookup binding (getExportsMap exportsMap) , [(ident, _)] <- filter (\(_,m) -> mod == m) (Set.toList match) = Just ident diff --git a/src/Development/IDE/Plugin/Formatter.hs b/src/Development/IDE/Plugin/Formatter.hs new file mode 100644 index 000000000..2dca7c3b6 --- /dev/null +++ b/src/Development/IDE/Plugin/Formatter.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} + +module Development.IDE.Plugin.Formatter + ( + formatting + , rangeFormatting + ) +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 +import Language.Haskell.LSP.Types +import Text.Regex.TDFA.Text() + +-- --------------------------------------------------------------------- + +formatting :: Map.Map PluginId (FormattingProvider IdeState 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 IdeState 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 IdeState 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 "" + ] + diff --git a/src/Development/IDE/Plugin/GhcIde.hs b/src/Development/IDE/Plugin/GhcIde.hs new file mode 100644 index 000000000..66e1b0986 --- /dev/null +++ b/src/Development/IDE/Plugin/GhcIde.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +module Development.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.PluginUtils +import Ide.Types +import Language.Haskell.LSP.Types +import Text.Regex.TDFA.Text() + +-- --------------------------------------------------------------------- + +descriptor :: PluginId -> PluginDescriptor IdeState +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 IdeState +hover' ideState params = do + logInfo (ideLogger ideState) "GhcIde.hover entered (ideLogger)" -- AZ + hover ideState params + +-- --------------------------------------------------------------------- + +commandAddSignature :: CommandFunction IdeState WorkspaceEdit +commandAddSignature lf ide params + = commandHandler lf ide (ExecuteCommandParams "typesignature.add" (Just (List [toJSON params])) Nothing) + +-- --------------------------------------------------------------------- + +codeAction' :: CodeActionProvider IdeState +codeAction' lf ide _ doc range context = fmap List <$> codeAction lf ide doc range context + +-- --------------------------------------------------------------------- + +codeLens' :: CodeLensProvider IdeState +codeLens' lf ide _ params = codeLens lf ide params + +-- --------------------------------------------------------------------- + +symbolsProvider :: SymbolsProvider IdeState +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/src/Development/IDE/Plugin/HLS.hs b/src/Development/IDE/Plugin/HLS.hs new file mode 100644 index 000000000..b32800b9e --- /dev/null +++ b/src/Development/IDE/Plugin/HLS.hs @@ -0,0 +1,585 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Development.IDE.Plugin.HLS + ( + asGhcIdePlugin + ) where + +import Control.Exception(SomeException, catch) +import Control.Lens ( (^.) ) +import Control.Monad +import qualified Data.Aeson as J +import Data.Either +import qualified Data.List as List +import qualified Data.Map as Map +import Data.Maybe +import qualified Data.Text as T +import Development.IDE.Core.Shake +import Development.IDE.LSP.Server +import Development.IDE.Plugin +import Development.IDE.Plugin.Formatter +import GHC.Generics +import Ide.Plugin.Config +import Ide.Types as HLS +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() +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 IdeState -> Plugin Config +asGhcIdePlugin mp = + mkPlugin rulesPlugins (Just . HLS.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 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 + -- create the plugin – otherwise we we end up declaring handlers for + -- capabilities that there are no plugins for + [] -> mempty + xs -> maker xs + +-- --------------------------------------------------------------------- + +rulesPlugins :: [(PluginId, Rules ())] -> Plugin Config +rulesPlugins rs = Plugin rules mempty + where + rules = mconcat $ map snd rs + +codeActionPlugins :: [(PluginId, CodeActionProvider IdeState)] -> Plugin Config +codeActionPlugins cas = Plugin codeActionRules (codeActionHandlers cas) + +codeActionRules :: Rules () +codeActionRules = mempty + +codeActionHandlers :: [(PluginId, CodeActionProvider IdeState)] -> PartialHandlers Config +codeActionHandlers cas = PartialHandlers $ \WithMessage{..} x -> return x + { LSP.codeActionHandler + = withResponse RspCodeAction (makeCodeAction cas) + } + +makeCodeAction :: [(PluginId, CodeActionProvider IdeState)] + -> 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 IdeState)] -> Plugin Config +codeLensPlugins cas = Plugin codeLensRules (codeLensHandlers cas) + +codeLensRules :: Rules () +codeLensRules = mempty + +codeLensHandlers :: [(PluginId, CodeLensProvider IdeState)] -> PartialHandlers Config +codeLensHandlers cas = PartialHandlers $ \WithMessage{..} x -> return x + { LSP.codeLensHandler + = withResponse RspCodeLens (makeCodeLens cas) + } + +makeCodeLens :: [(PluginId, CodeLensProvider IdeState)] + -> 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 IdeState])] -> Plugin Config +executeCommandPlugins ecs = Plugin mempty (executeCommandHandlers ecs) + +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 IdeState])] -> LSP.LspFuncs Config -> ExecuteCommandProvider IdeState +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 IdeState] + -> 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 <- T.pack . show <$> getProcessID + 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 + +-- --------------------------------------------------------------------- + +hoverPlugins :: [(PluginId, HoverProvider IdeState)] -> Plugin Config +hoverPlugins hs = Plugin hoverRules (hoverHandlers hs) + +hoverRules :: Rules () +hoverRules = mempty + +hoverHandlers :: [(PluginId, HoverProvider IdeState)] -> PartialHandlers Config +hoverHandlers hps = PartialHandlers $ \WithMessage{..} x -> + return x{LSP.hoverHandler = withResponse RspHover (makeHover hps)} + +makeHover :: [(PluginId, HoverProvider IdeState)] + -> 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 IdeState)] -> Plugin Config +symbolsPlugins hs = Plugin symbolsRules (symbolsHandlers hs) + +symbolsRules :: Rules () +symbolsRules = mempty + +symbolsHandlers :: [(PluginId, SymbolsProvider IdeState)] -> PartialHandlers Config +symbolsHandlers hps = PartialHandlers $ \WithMessage{..} x -> + return x {LSP.documentSymbolHandler = withResponse RspDocumentSymbols (makeSymbols hps)} + +makeSymbols :: [(PluginId, SymbolsProvider IdeState)] + -> 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 IdeState)] -> 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 IdeState)] -> + 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 IdeState IO)] -> Plugin Config +formatterPlugins providers + = Plugin formatterRules + (formatterHandlers (Map.fromList (("none",noneProvider):providers))) + +formatterRules :: Rules () +formatterRules = mempty + +formatterHandlers :: Map.Map PluginId (FormattingProvider IdeState 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 IdeState)] -> Plugin Config +completionsPlugins cs = Plugin completionsRules (completionsHandlers cs) + +completionsRules :: Rules () +completionsRules = mempty + +completionsHandlers :: [(PluginId, CompletionProvider IdeState)] -> PartialHandlers Config +completionsHandlers cps = PartialHandlers $ \WithMessage{..} x -> + return x {LSP.completionHandler = withResponse RspCompletion (makeCompletions cps)} + +makeCompletions :: [(PluginId, CompletionProvider IdeState)] + -> 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