{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Ide.Plugin
(
asGhcIdePlugin
, pluginDescToIdePlugins
, mkLspCommand
, allLspCmdIds
, allLspCmdIds'
, getPid
, responseError
) 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 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.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()
asGhcIdePlugin :: IdePlugins -> Plugin Config
asGhcIdePlugin mp =
mkPlugin rulesPlugins (Just . pluginRules) <>
mkPlugin executeCommandPlugins (Just . pluginCommands) <>
mkPlugin codeActionPlugins pluginCodeActionProvider <>
mkPlugin codeLensPlugins pluginCodeLensProvider <>
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
[] -> 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
r <- mapM (\(pid,provider) -> provider lf ideState pid docId range context) 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)"
let
makeLens (pid, provider) = do
r <- provider lf ideState pid params
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)
}
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
let cmdParams :: J.Value
cmdParams = case args of
Just (J.List (x:_)) -> x
_ -> J.Null
case parseCmdId cmdId of
Just ("hls", "fallbackCodeAction") ->
case J.fromJSON cmdParams of
J.Success (FallbackCodeActionParams mEdit mCmd) -> do
forM_ mEdit $ \edit -> do
let eParams = J.ApplyWorkspaceEditParams edit
return (Right J.Null, Just(J.WorkspaceApplyEdit, eParams))
case mCmd of
Just (J.Command _ innerCmdId innerArgs)
-> execCmd (ExecuteCommandParams innerCmdId innerArgs Nothing)
Nothing -> return (Right J.Null, Nothing)
J.Error _str -> return (Right J.Null, Nothing)
Just (plugin, cmd) -> runPluginCommand pluginMap lf ide plugin cmd cmdParams
_ -> return (Left $ ResponseError InvalidParams "Invalid command identifier" Nothing, Nothing)
execCmd
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)
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
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
mhs <- mapM (\(_,p) -> p ideState params) hps
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'
mhs <- mapM (\(_,p) -> p lf ideState params) 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
results <- mapM (\(_,p) -> p lspFuncs state params) 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
case mprefix of
Nothing -> return $ Right $ Completions $ List []
Just _prefix -> do
mhs <- mapM (\(_,p) -> p lf ideState params) sps
case rights mhs of
[] -> return $ Left $ responseError $ T.pack $ show $ lefts mhs
hs -> return $ Right $ combine hs
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
getClientConfig :: LSP.LspFuncs Config -> IO Config
getClientConfig lf = fromMaybe Data.Default.def <$> LSP.config lf