{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
module Development.IDE.Plugin.HLS
(
asGhcIdePlugin
, Log(..)
) where
import Control.Exception (SomeException)
import Control.Lens ((^.))
import Control.Monad
import qualified Data.Aeson as J
import Data.Bifunctor (first)
import Data.Dependent.Map (DMap)
import qualified Data.Dependent.Map as DMap
import Data.Dependent.Sum
import Data.Either
import qualified Data.List as List
import Data.List.NonEmpty (NonEmpty, nonEmpty, toList)
import qualified Data.List.NonEmpty as NE
import qualified Data.Map as Map
import Data.Some
import Data.String
import Data.Text (Text)
import qualified Data.Text as T
import Development.IDE.Core.Shake hiding (Log)
import Development.IDE.Core.Tracing
import Development.IDE.Graph (Rules)
import Development.IDE.LSP.Server
import Development.IDE.Plugin
import qualified Development.IDE.Plugin as P
import Development.IDE.Types.Logger
import Ide.Plugin.Config
import Ide.PluginUtils (getClientConfig)
import Ide.Types as HLS
import qualified Language.LSP.Server as LSP
import Language.LSP.Types
import qualified Language.LSP.Types as J
import qualified Language.LSP.Types.Lens as LSP
import Language.LSP.VFS
import Prettyprinter.Render.String (renderString)
import Text.Regex.TDFA.Text ()
import UnliftIO (MonadUnliftIO)
import UnliftIO.Async (forConcurrently)
import UnliftIO.Exception (catchAny)
data Log
= LogPluginError PluginId ResponseError
| LogNoPluginForMethod (Some SMethod)
| LogInvalidCommandIdentifier
instance Pretty Log where
pretty :: forall ann. Log -> Doc ann
pretty = \case
LogPluginError (PluginId Text
pId) ResponseError
err -> forall a ann. Pretty a => a -> Doc ann
pretty Text
pId forall a. Semigroup a => a -> a -> a
<> Doc ann
":" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a. ResponseError -> Doc a
prettyResponseError ResponseError
err
LogNoPluginForMethod (Some SMethod a
method) ->
Doc ann
"No plugin enabled for " forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty (forall a. Show a => a -> String
show SMethod a
method)
Log
LogInvalidCommandIdentifier-> Doc ann
"Invalid command identifier"
instance Show Log where show :: Log -> String
show = forall ann. SimpleDocStream ann -> String
renderString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ann1 ann2. Doc ann1 -> SimpleDocStream ann2
layoutCompact forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a ann. Pretty a => a -> Doc ann
pretty
prettyResponseError :: ResponseError -> Doc a
prettyResponseError :: forall a. ResponseError -> Doc a
prettyResponseError ResponseError
err = Doc a
errorCode forall a. Semigroup a => a -> a -> a
<> Doc a
":" forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc a
errorBody
where
errorCode :: Doc a
errorCode = forall a ann. Pretty a => a -> Doc ann
pretty forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ ResponseError
err forall s a. s -> Getting a s a -> a
^. forall s a. HasCode s a => Lens' s a
LSP.code
errorBody :: Doc a
errorBody = forall a ann. Pretty a => a -> Doc ann
pretty forall a b. (a -> b) -> a -> b
$ ResponseError
err forall s a. s -> Getting a s a -> a
^. forall s a. HasMessage s a => Lens' s a
LSP.message
pluginNotEnabled :: SMethod m -> [(PluginId, b, a)] -> Text
pluginNotEnabled :: forall {f :: From} {t :: MethodType} (m :: Method f t) b a.
SMethod m -> [(PluginId, b, a)] -> Text
pluginNotEnabled SMethod m
method [(PluginId, b, a)]
availPlugins =
Text
"No plugin enabled for " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall a. Show a => a -> String
show SMethod m
method) forall a. Semigroup a => a -> a -> a
<> Text
", available: "
forall a. Semigroup a => a -> a -> a
<> (Text -> [Text] -> Text
T.intercalate Text
", " forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\(PluginId Text
plid, b
_, a
_) -> Text
plid) [(PluginId, b, a)]
availPlugins)
pluginDoesntExist :: PluginId -> Text
pluginDoesntExist :: PluginId -> Text
pluginDoesntExist (PluginId Text
pid) = Text
"Plugin " forall a. Semigroup a => a -> a -> a
<> Text
pid forall a. Semigroup a => a -> a -> a
<> Text
" doesn't exist"
commandDoesntExist :: CommandId -> PluginId -> [PluginCommand ideState] -> Text
commandDoesntExist :: forall ideState.
CommandId -> PluginId -> [PluginCommand ideState] -> Text
commandDoesntExist (CommandId Text
com) (PluginId Text
pid) [PluginCommand ideState]
legalCmds =
Text
"Command " forall a. Semigroup a => a -> a -> a
<> Text
com forall a. Semigroup a => a -> a -> a
<> Text
" isn't defined for plugin " forall a. Semigroup a => a -> a -> a
<> Text
pid forall a. Semigroup a => a -> a -> a
<> Text
". Legal commands are: "
forall a. Semigroup a => a -> a -> a
<> (Text -> [Text] -> Text
T.intercalate Text
", " forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\(PluginCommand{commandId :: forall ideState. PluginCommand ideState -> CommandId
commandId = CommandId Text
cid}) -> Text
cid) [PluginCommand ideState]
legalCmds)
failedToParseArgs :: CommandId
-> PluginId
-> String
-> J.Value
-> Text
failedToParseArgs :: CommandId -> PluginId -> String -> Value -> Text
failedToParseArgs (CommandId Text
com) (PluginId Text
pid) String
err Value
arg =
Text
"Error while parsing args for " forall a. Semigroup a => a -> a -> a
<> Text
com forall a. Semigroup a => a -> a -> a
<> Text
" in plugin " forall a. Semigroup a => a -> a -> a
<> Text
pid forall a. Semigroup a => a -> a -> a
<> Text
": "
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
err forall a. Semigroup a => a -> a -> a
<> Text
", arg = " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall a. Show a => a -> String
show Value
arg)
logAndReturnError :: Recorder (WithPriority Log) -> PluginId -> ErrorCode -> Text -> LSP.LspT Config IO (Either ResponseError a)
logAndReturnError :: forall a.
Recorder (WithPriority Log)
-> PluginId
-> ErrorCode
-> Text
-> LspT Config IO (Either ResponseError a)
logAndReturnError Recorder (WithPriority Log)
recorder PluginId
p ErrorCode
errCode Text
msg = do
let err :: ResponseError
err = ErrorCode -> Text -> Maybe Value -> ResponseError
ResponseError ErrorCode
errCode Text
msg forall a. Maybe a
Nothing
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Warning forall a b. (a -> b) -> a -> b
$ PluginId -> ResponseError -> Log
LogPluginError PluginId
p ResponseError
err
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left ResponseError
err
asGhcIdePlugin :: Recorder (WithPriority Log) -> IdePlugins IdeState -> Plugin Config
asGhcIdePlugin :: Recorder (WithPriority Log) -> IdePlugins IdeState -> Plugin Config
asGhcIdePlugin Recorder (WithPriority Log)
recorder (IdePlugins [PluginDescriptor IdeState]
ls) =
forall {b}.
([(PluginId, b)] -> Plugin Config)
-> (PluginDescriptor IdeState -> b) -> Plugin Config
mkPlugin [(PluginId, Rules ())] -> Plugin Config
rulesPlugins forall ideState. PluginDescriptor ideState -> Rules ()
HLS.pluginRules forall a. Semigroup a => a -> a -> a
<>
forall {b}.
([(PluginId, b)] -> Plugin Config)
-> (PluginDescriptor IdeState -> b) -> Plugin Config
mkPlugin (Recorder (WithPriority Log)
-> [(PluginId, [PluginCommand IdeState])] -> Plugin Config
executeCommandPlugins Recorder (WithPriority Log)
recorder) forall ideState.
PluginDescriptor ideState -> [PluginCommand ideState]
HLS.pluginCommands forall a. Semigroup a => a -> a -> a
<>
forall {b}.
([(PluginId, b)] -> Plugin Config)
-> (PluginDescriptor IdeState -> b) -> Plugin Config
mkPlugin (Recorder (WithPriority Log)
-> [(PluginId, PluginDescriptor IdeState)] -> Plugin Config
extensiblePlugins Recorder (WithPriority Log)
recorder) forall a. a -> a
id forall a. Semigroup a => a -> a -> a
<>
forall {b}.
([(PluginId, b)] -> Plugin Config)
-> (PluginDescriptor IdeState -> b) -> Plugin Config
mkPlugin (Recorder (WithPriority Log)
-> [(PluginId, PluginDescriptor IdeState)] -> Plugin Config
extensibleNotificationPlugins Recorder (WithPriority Log)
recorder) forall a. a -> a
id forall a. Semigroup a => a -> a -> a
<>
forall b.
([(PluginDescriptor IdeState, b)] -> Plugin Config)
-> (PluginDescriptor IdeState -> b) -> Plugin Config
mkPluginFromDescriptor forall c.
[(PluginDescriptor c, DynFlagsModifications)] -> Plugin Config
dynFlagsPlugins forall ideState. PluginDescriptor ideState -> DynFlagsModifications
HLS.pluginModifyDynflags
where
mkPlugin :: ([(PluginId, b)] -> Plugin Config)
-> (PluginDescriptor IdeState -> b) -> Plugin Config
mkPlugin [(PluginId, b)] -> Plugin Config
f = forall b.
([(PluginDescriptor IdeState, b)] -> Plugin Config)
-> (PluginDescriptor IdeState -> b) -> Plugin Config
mkPluginFromDescriptor ([(PluginId, b)] -> Plugin Config
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall ideState. PluginDescriptor ideState -> PluginId
pluginId))
mkPluginFromDescriptor
:: ([(PluginDescriptor IdeState, b)]
-> Plugin Config)
-> (PluginDescriptor IdeState -> b)
-> Plugin Config
mkPluginFromDescriptor :: forall b.
([(PluginDescriptor IdeState, b)] -> Plugin Config)
-> (PluginDescriptor IdeState -> b) -> Plugin Config
mkPluginFromDescriptor [(PluginDescriptor IdeState, b)] -> Plugin Config
maker PluginDescriptor IdeState -> b
selector =
case forall a b. (a -> b) -> [a] -> [b]
map (\PluginDescriptor IdeState
p -> (PluginDescriptor IdeState
p, PluginDescriptor IdeState -> b
selector PluginDescriptor IdeState
p)) [PluginDescriptor IdeState]
ls of
[] -> forall a. Monoid a => a
mempty
[(PluginDescriptor IdeState, b)]
xs -> [(PluginDescriptor IdeState, b)] -> Plugin Config
maker [(PluginDescriptor IdeState, b)]
xs
rulesPlugins :: [(PluginId, Rules ())] -> Plugin Config
rulesPlugins :: [(PluginId, Rules ())] -> Plugin Config
rulesPlugins [(PluginId, Rules ())]
rs = forall a. Monoid a => a
mempty { pluginRules :: Rules ()
P.pluginRules = Rules ()
rules }
where
rules :: Rules ()
rules = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall a b. (a, b) -> b
snd [(PluginId, Rules ())]
rs
dynFlagsPlugins :: [(PluginDescriptor c, DynFlagsModifications)] -> Plugin Config
dynFlagsPlugins :: forall c.
[(PluginDescriptor c, DynFlagsModifications)] -> Plugin Config
dynFlagsPlugins [(PluginDescriptor c, DynFlagsModifications)]
rs = forall a. Monoid a => a
mempty
{ pluginModifyDynflags :: Config -> DynFlagsModifications
P.pluginModifyDynflags =
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap [(PluginDescriptor c, DynFlagsModifications)]
rs forall a b. (a -> b) -> a -> b
$ \(PluginDescriptor c
plId, DynFlagsModifications
dflag_mods) Config
cfg ->
let plg_cfg :: PluginConfig
plg_cfg = forall c. Config -> PluginDescriptor c -> PluginConfig
configForPlugin Config
cfg PluginDescriptor c
plId
in if PluginConfig -> Bool
plcGlobalOn PluginConfig
plg_cfg
then DynFlagsModifications
dflag_mods
else forall a. Monoid a => a
mempty
}
executeCommandPlugins :: Recorder (WithPriority Log) -> [(PluginId, [PluginCommand IdeState])] -> Plugin Config
executeCommandPlugins :: Recorder (WithPriority Log)
-> [(PluginId, [PluginCommand IdeState])] -> Plugin Config
executeCommandPlugins Recorder (WithPriority Log)
recorder [(PluginId, [PluginCommand IdeState])]
ecs = forall a. Monoid a => a
mempty { pluginHandlers :: Handlers (ServerM Config)
P.pluginHandlers = Recorder (WithPriority Log)
-> [(PluginId, [PluginCommand IdeState])]
-> Handlers (ServerM Config)
executeCommandHandlers Recorder (WithPriority Log)
recorder [(PluginId, [PluginCommand IdeState])]
ecs }
executeCommandHandlers :: Recorder (WithPriority Log) -> [(PluginId, [PluginCommand IdeState])] -> LSP.Handlers (ServerM Config)
executeCommandHandlers :: Recorder (WithPriority Log)
-> [(PluginId, [PluginCommand IdeState])]
-> Handlers (ServerM Config)
executeCommandHandlers Recorder (WithPriority Log)
recorder [(PluginId, [PluginCommand IdeState])]
ecs = forall (m :: Method 'FromClient 'Request) c.
HasTracing (MessageParams m) =>
SMethod m
-> (IdeState
-> MessageParams m
-> LspM c (Either ResponseError (ResponseResult m)))
-> Handlers (ServerM c)
requestHandler SMethod 'WorkspaceExecuteCommand
SWorkspaceExecuteCommand IdeState
-> ExecuteCommandParams
-> LspT Config IO (Either ResponseError Value)
execCmd
where
pluginMap :: Map PluginId [PluginCommand IdeState]
pluginMap = forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith forall a. [a] -> [a] -> [a]
(++) [(PluginId, [PluginCommand IdeState])]
ecs
parseCmdId :: T.Text -> Maybe (PluginId, CommandId)
parseCmdId :: Text -> Maybe (PluginId, CommandId)
parseCmdId Text
x = case Text -> Text -> [Text]
T.splitOn Text
":" Text
x of
[Text
plugin, Text
command] -> forall a. a -> Maybe a
Just (Text -> PluginId
PluginId Text
plugin, Text -> CommandId
CommandId Text
command)
[Text
_, Text
plugin, Text
command] -> forall a. a -> Maybe a
Just (Text -> PluginId
PluginId Text
plugin, Text -> CommandId
CommandId Text
command)
[Text]
_ -> forall a. Maybe a
Nothing
execCmd :: IdeState
-> ExecuteCommandParams
-> LspT Config IO (Either ResponseError Value)
execCmd IdeState
ide (ExecuteCommandParams Maybe ProgressToken
_ Text
cmdId Maybe (List Value)
args) = do
let cmdParams :: J.Value
cmdParams :: Value
cmdParams = case Maybe (List Value)
args of
Just (J.List (Value
x:[Value]
_)) -> Value
x
Maybe (List Value)
_ -> Value
J.Null
case Text -> Maybe (PluginId, CommandId)
parseCmdId Text
cmdId of
Just (PluginId
"hls", CommandId
"fallbackCodeAction") ->
case forall a. FromJSON a => Value -> Result a
J.fromJSON Value
cmdParams of
J.Success (FallbackCodeActionParams Maybe WorkspaceEdit
mEdit Maybe Command
mCmd) -> do
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe WorkspaceEdit
mEdit forall a b. (a -> b) -> a -> b
$ \WorkspaceEdit
edit ->
forall (m :: Method 'FromServer 'Request) (f :: * -> *) config.
MonadLsp config f =>
SServerMethod m
-> MessageParams m
-> (Either ResponseError (ResponseResult m) -> f ())
-> f (LspId m)
LSP.sendRequest SMethod 'WorkspaceApplyEdit
SWorkspaceApplyEdit (Maybe Text -> WorkspaceEdit -> ApplyWorkspaceEditParams
ApplyWorkspaceEditParams forall a. Maybe a
Nothing WorkspaceEdit
edit) (\Either ResponseError (ResponseResult 'WorkspaceApplyEdit)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
case Maybe Command
mCmd of
Just (J.Command Text
_ Text
innerCmdId Maybe (List Value)
innerArgs)
-> IdeState
-> ExecuteCommandParams
-> LspT Config IO (Either ResponseError Value)
execCmd IdeState
ide (Maybe ProgressToken
-> Text -> Maybe (List Value) -> ExecuteCommandParams
ExecuteCommandParams forall a. Maybe a
Nothing Text
innerCmdId Maybe (List Value)
innerArgs)
Maybe Command
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right Value
J.Null
J.Error String
_str -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right Value
J.Null
Just (PluginId
plugin, CommandId
cmd) -> IdeState
-> PluginId
-> CommandId
-> Value
-> LspT Config IO (Either ResponseError Value)
runPluginCommand IdeState
ide PluginId
plugin CommandId
cmd Value
cmdParams
Maybe (PluginId, CommandId)
_ -> do
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Warning Log
LogInvalidCommandIdentifier
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ ErrorCode -> Text -> Maybe Value -> ResponseError
ResponseError ErrorCode
InvalidParams Text
"Invalid command identifier" forall a. Maybe a
Nothing
runPluginCommand :: IdeState
-> PluginId
-> CommandId
-> Value
-> LspT Config IO (Either ResponseError Value)
runPluginCommand IdeState
ide PluginId
p CommandId
com Value
arg =
case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PluginId
p Map PluginId [PluginCommand IdeState]
pluginMap of
Maybe [PluginCommand IdeState]
Nothing -> forall a.
Recorder (WithPriority Log)
-> PluginId
-> ErrorCode
-> Text
-> LspT Config IO (Either ResponseError a)
logAndReturnError Recorder (WithPriority Log)
recorder PluginId
p ErrorCode
InvalidRequest (PluginId -> Text
pluginDoesntExist PluginId
p)
Just [PluginCommand IdeState]
xs -> case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find ((CommandId
com forall a. Eq a => a -> a -> Bool
==) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ideState. PluginCommand ideState -> CommandId
commandId) [PluginCommand IdeState]
xs of
Maybe (PluginCommand IdeState)
Nothing -> forall a.
Recorder (WithPriority Log)
-> PluginId
-> ErrorCode
-> Text
-> LspT Config IO (Either ResponseError a)
logAndReturnError Recorder (WithPriority Log)
recorder PluginId
p ErrorCode
InvalidRequest (forall ideState.
CommandId -> PluginId -> [PluginCommand ideState] -> Text
commandDoesntExist CommandId
com PluginId
p [PluginCommand IdeState]
xs)
Just (PluginCommand CommandId
_ Text
_ CommandFunction IdeState a
f) -> case forall a. FromJSON a => Value -> Result a
J.fromJSON Value
arg of
J.Error String
err -> forall a.
Recorder (WithPriority Log)
-> PluginId
-> ErrorCode
-> Text
-> LspT Config IO (Either ResponseError a)
logAndReturnError Recorder (WithPriority Log)
recorder PluginId
p ErrorCode
InvalidParams (CommandId -> PluginId -> String -> Value -> Text
failedToParseArgs CommandId
com PluginId
p String
err Value
arg)
J.Success a
a -> CommandFunction IdeState a
f IdeState
ide a
a
extensiblePlugins :: Recorder (WithPriority Log) -> [(PluginId, PluginDescriptor IdeState)] -> Plugin Config
extensiblePlugins :: Recorder (WithPriority Log)
-> [(PluginId, PluginDescriptor IdeState)] -> Plugin Config
extensiblePlugins Recorder (WithPriority Log)
recorder [(PluginId, PluginDescriptor IdeState)]
xs = forall a. Monoid a => a
mempty { pluginHandlers :: Handlers (ServerM Config)
P.pluginHandlers = Handlers (ServerM Config)
handlers }
where
IdeHandlers DMap IdeMethod IdeHandler
handlers' = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (PluginId, PluginDescriptor IdeState) -> IdeHandlers
bakePluginId [(PluginId, PluginDescriptor IdeState)]
xs
bakePluginId :: (PluginId, PluginDescriptor IdeState) -> IdeHandlers
bakePluginId :: (PluginId, PluginDescriptor IdeState) -> IdeHandlers
bakePluginId (PluginId
pid,PluginDescriptor IdeState
pluginDesc) = DMap IdeMethod IdeHandler -> IdeHandlers
IdeHandlers forall a b. (a -> b) -> a -> b
$ forall {k1} (f :: k1 -> *) (g :: k1 -> *) (k2 :: k1 -> *).
(forall (v :: k1). f v -> g v) -> DMap k2 f -> DMap k2 g
DMap.map
(\(PluginHandler PluginId
-> IdeState
-> MessageParams v
-> LspM Config (NonEmpty (Either ResponseError (ResponseResult v)))
f) -> forall (m :: Method 'FromClient 'Request).
[(PluginId, PluginDescriptor IdeState,
IdeState
-> MessageParams m
-> LspM
Config (NonEmpty (Either ResponseError (ResponseResult m))))]
-> IdeHandler m
IdeHandler [(PluginId
pid,PluginDescriptor IdeState
pluginDesc,PluginId
-> IdeState
-> MessageParams v
-> LspM Config (NonEmpty (Either ResponseError (ResponseResult v)))
f PluginId
pid)])
DMap IdeMethod (PluginHandler IdeState)
hs
where
PluginHandlers DMap IdeMethod (PluginHandler IdeState)
hs = forall ideState.
PluginDescriptor ideState -> PluginHandlers ideState
HLS.pluginHandlers PluginDescriptor IdeState
pluginDesc
handlers :: Handlers (ServerM Config)
handlers = forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ do
(IdeMethod SMethod a
m :=> IdeHandler [(PluginId, PluginDescriptor IdeState,
IdeState
-> MessageParams a
-> LspM
Config (NonEmpty (Either ResponseError (ResponseResult a))))]
fs') <- forall {k1} (k2 :: k1 -> *) (f :: k1 -> *).
DMap k2 f -> [DSum k2 f]
DMap.assocs DMap IdeMethod IdeHandler
handlers'
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (m :: Method 'FromClient 'Request) c.
HasTracing (MessageParams m) =>
SMethod m
-> (IdeState
-> MessageParams m
-> LspM c (Either ResponseError (ResponseResult m)))
-> Handlers (ServerM c)
requestHandler SMethod a
m forall a b. (a -> b) -> a -> b
$ \IdeState
ide MessageParams a
params -> do
Config
config <- forall (m :: * -> *). MonadLsp Config m => m Config
Ide.PluginUtils.getClientConfig
let fs :: [(PluginId, PluginDescriptor IdeState,
IdeState
-> MessageParams a
-> LspM
Config (NonEmpty (Either ResponseError (ResponseResult a))))]
fs = forall a. (a -> Bool) -> [a] -> [a]
filter (\(PluginId
_, PluginDescriptor IdeState
desc, IdeState
-> MessageParams a
-> LspM Config (NonEmpty (Either ResponseError (ResponseResult a)))
_) -> forall (k :: MethodType) (m :: Method 'FromClient k) c.
PluginMethod k m =>
SMethod m
-> MessageParams m -> PluginDescriptor c -> Config -> Bool
pluginEnabled SMethod a
m MessageParams a
params PluginDescriptor IdeState
desc Config
config) [(PluginId, PluginDescriptor IdeState,
IdeState
-> MessageParams a
-> LspM
Config (NonEmpty (Either ResponseError (ResponseResult a))))]
fs'
case forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [(PluginId, PluginDescriptor IdeState,
IdeState
-> MessageParams a
-> LspM
Config (NonEmpty (Either ResponseError (ResponseResult a))))]
fs of
Maybe
(NonEmpty
(PluginId, PluginDescriptor IdeState,
IdeState
-> MessageParams a
-> LspM
Config (NonEmpty (Either ResponseError (ResponseResult a)))))
Nothing -> do
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Warning (forall {f :: From} {t :: MethodType}. Some SMethod -> Log
LogNoPluginForMethod forall a b. (a -> b) -> a -> b
$ forall {k} (tag :: k -> *) (a :: k). tag a -> Some tag
Some SMethod a
m)
let err :: ResponseError
err = ErrorCode -> Text -> Maybe Value -> ResponseError
ResponseError ErrorCode
InvalidRequest Text
msg forall a. Maybe a
Nothing
msg :: Text
msg = forall {f :: From} {t :: MethodType} (m :: Method f t) b a.
SMethod m -> [(PluginId, b, a)] -> Text
pluginNotEnabled SMethod a
m [(PluginId, PluginDescriptor IdeState,
IdeState
-> MessageParams a
-> LspM
Config (NonEmpty (Either ResponseError (ResponseResult a))))]
fs'
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left ResponseError
err
Just NonEmpty
(PluginId, PluginDescriptor IdeState,
IdeState
-> MessageParams a
-> LspM
Config (NonEmpty (Either ResponseError (ResponseResult a))))
fs -> do
let msg :: SomeException -> PluginId -> Text
msg SomeException
e PluginId
pid = Text
"Exception in plugin " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall a. Show a => a -> String
show PluginId
pid) forall a. Semigroup a => a -> a -> a
<> Text
" while processing " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall a. Show a => a -> String
show SMethod a
m) forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall a. Show a => a -> String
show SomeException
e)
handlers :: NonEmpty
(PluginId,
IdeState
-> MessageParams a
-> LspM
Config (NonEmpty (Either ResponseError (ResponseResult a))))
handlers = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(PluginId
plid,PluginDescriptor IdeState
_,IdeState
-> MessageParams a
-> LspM Config (NonEmpty (Either ResponseError (ResponseResult a)))
handler) -> (PluginId
plid,IdeState
-> MessageParams a
-> LspM Config (NonEmpty (Either ResponseError (ResponseResult a)))
handler)) NonEmpty
(PluginId, PluginDescriptor IdeState,
IdeState
-> MessageParams a
-> LspM
Config (NonEmpty (Either ResponseError (ResponseResult a))))
fs
NonEmpty (NonEmpty (Either ResponseError (ResponseResult a)))
es <- forall (m :: * -> *) a b d.
MonadUnliftIO m =>
(SomeException -> PluginId -> Text)
-> String
-> NonEmpty
(PluginId, a -> b -> m (NonEmpty (Either ResponseError d)))
-> a
-> b
-> m (NonEmpty (NonEmpty (Either ResponseError d)))
runConcurrently SomeException -> PluginId -> Text
msg (forall a. Show a => a -> String
show SMethod a
m) NonEmpty
(PluginId,
IdeState
-> MessageParams a
-> LspM
Config (NonEmpty (Either ResponseError (ResponseResult a))))
handlers IdeState
ide MessageParams a
params
let ([(PluginId, ResponseError)]
errs,[ResponseResult a]
succs) = forall a b. [Either a b] -> ([a], [b])
partitionEithers forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
toList forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall a b c.
(a -> b -> c) -> NonEmpty a -> NonEmpty b -> NonEmpty c
NE.zipWith (\(PluginId
pId,IdeState
-> MessageParams a
-> LspM Config (NonEmpty (Either ResponseError (ResponseResult a)))
_) -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (PluginId
pId,))) NonEmpty
(PluginId,
IdeState
-> MessageParams a
-> LspM
Config (NonEmpty (Either ResponseError (ResponseResult a))))
handlers NonEmpty (NonEmpty (Either ResponseError (ResponseResult a)))
es
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(PluginId, ResponseError)]
errs) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(PluginId, ResponseError)]
errs forall a b. (a -> b) -> a -> b
$ \(PluginId
pId, ResponseError
err) ->
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Warning forall a b. (a -> b) -> a -> b
$ PluginId -> ResponseError -> Log
LogPluginError PluginId
pId ResponseError
err
case forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [ResponseResult a]
succs of
Maybe (NonEmpty (ResponseResult a))
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [ResponseError] -> ResponseError
combineErrors forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(PluginId, ResponseError)]
errs
Just NonEmpty (ResponseResult a)
xs -> do
ClientCapabilities
caps <- forall config (m :: * -> *).
MonadLsp config m =>
m ClientCapabilities
LSP.getClientCapabilities
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall (m :: Method 'FromClient 'Request).
PluginRequestMethod m =>
SMethod m
-> Config
-> ClientCapabilities
-> MessageParams m
-> NonEmpty (ResponseResult m)
-> ResponseResult m
combineResponses SMethod a
m Config
config ClientCapabilities
caps MessageParams a
params NonEmpty (ResponseResult a)
xs
extensibleNotificationPlugins :: Recorder (WithPriority Log) -> [(PluginId, PluginDescriptor IdeState)] -> Plugin Config
extensibleNotificationPlugins :: Recorder (WithPriority Log)
-> [(PluginId, PluginDescriptor IdeState)] -> Plugin Config
extensibleNotificationPlugins Recorder (WithPriority Log)
recorder [(PluginId, PluginDescriptor IdeState)]
xs = forall a. Monoid a => a
mempty { pluginHandlers :: Handlers (ServerM Config)
P.pluginHandlers = Handlers (ServerM Config)
handlers }
where
IdeNotificationHandlers DMap IdeNotification IdeNotificationHandler
handlers' = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (PluginId, PluginDescriptor IdeState) -> IdeNotificationHandlers
bakePluginId [(PluginId, PluginDescriptor IdeState)]
xs
bakePluginId :: (PluginId, PluginDescriptor IdeState) -> IdeNotificationHandlers
bakePluginId :: (PluginId, PluginDescriptor IdeState) -> IdeNotificationHandlers
bakePluginId (PluginId
pid,PluginDescriptor IdeState
pluginDesc) = DMap IdeNotification IdeNotificationHandler
-> IdeNotificationHandlers
IdeNotificationHandlers forall a b. (a -> b) -> a -> b
$ forall {k1} (f :: k1 -> *) (g :: k1 -> *) (k2 :: k1 -> *).
(forall (v :: k1). f v -> g v) -> DMap k2 f -> DMap k2 g
DMap.map
(\(PluginNotificationHandler PluginId -> IdeState -> VFS -> MessageParams v -> LspT Config IO ()
f) -> forall (m :: Method 'FromClient 'Notification).
[(PluginId, PluginDescriptor IdeState,
IdeState -> VFS -> MessageParams m -> LspT Config IO ())]
-> IdeNotificationHandler m
IdeNotificationHandler [(PluginId
pid,PluginDescriptor IdeState
pluginDesc,PluginId -> IdeState -> VFS -> MessageParams v -> LspT Config IO ()
f PluginId
pid)])
DMap IdeNotification (PluginNotificationHandler IdeState)
hs
where PluginNotificationHandlers DMap IdeNotification (PluginNotificationHandler IdeState)
hs = forall ideState.
PluginDescriptor ideState -> PluginNotificationHandlers ideState
HLS.pluginNotificationHandlers PluginDescriptor IdeState
pluginDesc
handlers :: Handlers (ServerM Config)
handlers = forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ do
(IdeNotification SMethod a
m :=> IdeNotificationHandler [(PluginId, PluginDescriptor IdeState,
IdeState -> VFS -> MessageParams a -> LspT Config IO ())]
fs') <- forall {k1} (k2 :: k1 -> *) (f :: k1 -> *).
DMap k2 f -> [DSum k2 f]
DMap.assocs DMap IdeNotification IdeNotificationHandler
handlers'
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (m :: Method 'FromClient 'Notification) c.
HasTracing (MessageParams m) =>
SMethod m
-> (IdeState -> VFS -> MessageParams m -> LspM c ())
-> Handlers (ServerM c)
notificationHandler SMethod a
m forall a b. (a -> b) -> a -> b
$ \IdeState
ide VFS
vfs MessageParams a
params -> do
Config
config <- forall (m :: * -> *). MonadLsp Config m => m Config
Ide.PluginUtils.getClientConfig
let fs :: [(PluginId, PluginDescriptor IdeState,
IdeState -> VFS -> MessageParams a -> LspT Config IO ())]
fs = forall a. (a -> Bool) -> [a] -> [a]
filter (\(PluginId
_, PluginDescriptor IdeState
desc, IdeState -> VFS -> MessageParams a -> LspT Config IO ()
_) -> forall (k :: MethodType) (m :: Method 'FromClient k) c.
PluginMethod k m =>
SMethod m
-> MessageParams m -> PluginDescriptor c -> Config -> Bool
pluginEnabled SMethod a
m MessageParams a
params PluginDescriptor IdeState
desc Config
config) [(PluginId, PluginDescriptor IdeState,
IdeState -> VFS -> MessageParams a -> LspT Config IO ())]
fs'
case forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [(PluginId, PluginDescriptor IdeState,
IdeState -> VFS -> MessageParams a -> LspT Config IO ())]
fs of
Maybe
(NonEmpty
(PluginId, PluginDescriptor IdeState,
IdeState -> VFS -> MessageParams a -> LspT Config IO ()))
Nothing -> do
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Warning (forall {f :: From} {t :: MethodType}. Some SMethod -> Log
LogNoPluginForMethod forall a b. (a -> b) -> a -> b
$ forall {k} (tag :: k -> *) (a :: k). tag a -> Some tag
Some SMethod a
m)
Just NonEmpty
(PluginId, PluginDescriptor IdeState,
IdeState -> VFS -> MessageParams a -> LspT Config IO ())
fs -> do
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(PluginId
pid,PluginDescriptor IdeState
_,IdeState -> VFS -> MessageParams a -> LspT Config IO ()
f) -> forall (m :: * -> *) a.
MonadUnliftIO m =>
PluginId -> ByteString -> m a -> m a
otTracedProvider PluginId
pid (forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show SMethod a
m) forall a b. (a -> b) -> a -> b
$ IdeState -> VFS -> MessageParams a -> LspT Config IO ()
f IdeState
ide VFS
vfs MessageParams a
params) NonEmpty
(PluginId, PluginDescriptor IdeState,
IdeState -> VFS -> MessageParams a -> LspT Config IO ())
fs
runConcurrently
:: MonadUnliftIO m
=> (SomeException -> PluginId -> T.Text)
-> String
-> NonEmpty (PluginId, a -> b -> m (NonEmpty (Either ResponseError d)))
-> a
-> b
-> m (NonEmpty(NonEmpty (Either ResponseError d)))
runConcurrently :: forall (m :: * -> *) a b d.
MonadUnliftIO m =>
(SomeException -> PluginId -> Text)
-> String
-> NonEmpty
(PluginId, a -> b -> m (NonEmpty (Either ResponseError d)))
-> a
-> b
-> m (NonEmpty (NonEmpty (Either ResponseError d)))
runConcurrently SomeException -> PluginId -> Text
msg String
method NonEmpty
(PluginId, a -> b -> m (NonEmpty (Either ResponseError d)))
fs a
a b
b = forall (m :: * -> *) (t :: * -> *) a b.
(MonadUnliftIO m, Traversable t) =>
t a -> (a -> m b) -> m (t b)
forConcurrently NonEmpty
(PluginId, a -> b -> m (NonEmpty (Either ResponseError d)))
fs forall a b. (a -> b) -> a -> b
$ \(PluginId
pid,a -> b -> m (NonEmpty (Either ResponseError d))
f) -> forall (m :: * -> *) a.
MonadUnliftIO m =>
PluginId -> ByteString -> m a -> m a
otTracedProvider PluginId
pid (forall a. IsString a => String -> a
fromString String
method) forall a b. (a -> b) -> a -> b
$ do
a -> b -> m (NonEmpty (Either ResponseError d))
f a
a b
b
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`catchAny` (\SomeException
e -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ ErrorCode -> Text -> Maybe Value -> ResponseError
ResponseError ErrorCode
InternalError (SomeException -> PluginId -> Text
msg SomeException
e PluginId
pid) forall a. Maybe a
Nothing)
combineErrors :: [ResponseError] -> ResponseError
combineErrors :: [ResponseError] -> ResponseError
combineErrors [ResponseError
x] = ResponseError
x
combineErrors [ResponseError]
xs = ErrorCode -> Text -> Maybe Value -> ResponseError
ResponseError ErrorCode
InternalError (String -> Text
T.pack (forall a. Show a => a -> String
show [ResponseError]
xs)) forall a. Maybe a
Nothing
newtype IdeHandler (m :: J.Method FromClient Request)
= IdeHandler [(PluginId, PluginDescriptor IdeState, IdeState -> MessageParams m -> LSP.LspM Config (NonEmpty (Either ResponseError (ResponseResult m))))]
newtype IdeNotificationHandler (m :: J.Method FromClient Notification)
= IdeNotificationHandler [(PluginId, PluginDescriptor IdeState, IdeState -> VFS -> MessageParams m -> LSP.LspM Config ())]
newtype IdeHandlers = IdeHandlers (DMap IdeMethod IdeHandler)
newtype IdeNotificationHandlers = IdeNotificationHandlers (DMap IdeNotification IdeNotificationHandler)
instance Semigroup IdeHandlers where
(IdeHandlers DMap IdeMethod IdeHandler
a) <> :: IdeHandlers -> IdeHandlers -> IdeHandlers
<> (IdeHandlers DMap IdeMethod IdeHandler
b) = DMap IdeMethod IdeHandler -> IdeHandlers
IdeHandlers forall a b. (a -> b) -> a -> b
$ forall {k1} (k2 :: k1 -> *) (f :: k1 -> *).
GCompare k2 =>
(forall (v :: k1). k2 v -> f v -> f v -> f v)
-> DMap k2 f -> DMap k2 f -> DMap k2 f
DMap.unionWithKey forall {m :: Method 'FromClient 'Request}
{m :: Method 'FromClient 'Request}
{m :: Method 'FromClient 'Request} {p}.
(ResponseResult m ~ ResponseResult m,
ResponseResult m ~ ResponseResult m,
MessageParams m ~ MessageParams m,
MessageParams m ~ MessageParams m) =>
p -> IdeHandler m -> IdeHandler m -> IdeHandler m
go DMap IdeMethod IdeHandler
a DMap IdeMethod IdeHandler
b
where
go :: p -> IdeHandler m -> IdeHandler m -> IdeHandler m
go p
_ (IdeHandler [(PluginId, PluginDescriptor IdeState,
IdeState
-> MessageParams m
-> LspM
Config (NonEmpty (Either ResponseError (ResponseResult m))))]
a) (IdeHandler [(PluginId, PluginDescriptor IdeState,
IdeState
-> MessageParams m
-> LspM
Config (NonEmpty (Either ResponseError (ResponseResult m))))]
b) = forall (m :: Method 'FromClient 'Request).
[(PluginId, PluginDescriptor IdeState,
IdeState
-> MessageParams m
-> LspM
Config (NonEmpty (Either ResponseError (ResponseResult m))))]
-> IdeHandler m
IdeHandler ([(PluginId, PluginDescriptor IdeState,
IdeState
-> MessageParams m
-> LspM
Config (NonEmpty (Either ResponseError (ResponseResult m))))]
a forall a. Semigroup a => a -> a -> a
<> [(PluginId, PluginDescriptor IdeState,
IdeState
-> MessageParams m
-> LspM
Config (NonEmpty (Either ResponseError (ResponseResult m))))]
b)
instance Monoid IdeHandlers where
mempty :: IdeHandlers
mempty = DMap IdeMethod IdeHandler -> IdeHandlers
IdeHandlers forall a. Monoid a => a
mempty
instance Semigroup IdeNotificationHandlers where
(IdeNotificationHandlers DMap IdeNotification IdeNotificationHandler
a) <> :: IdeNotificationHandlers
-> IdeNotificationHandlers -> IdeNotificationHandlers
<> (IdeNotificationHandlers DMap IdeNotification IdeNotificationHandler
b) = DMap IdeNotification IdeNotificationHandler
-> IdeNotificationHandlers
IdeNotificationHandlers forall a b. (a -> b) -> a -> b
$ forall {k1} (k2 :: k1 -> *) (f :: k1 -> *).
GCompare k2 =>
(forall (v :: k1). k2 v -> f v -> f v -> f v)
-> DMap k2 f -> DMap k2 f -> DMap k2 f
DMap.unionWithKey forall {m :: Method 'FromClient 'Notification}
{m :: Method 'FromClient 'Notification}
{m :: Method 'FromClient 'Notification} {p}.
(MessageParams m ~ MessageParams m,
MessageParams m ~ MessageParams m) =>
p
-> IdeNotificationHandler m
-> IdeNotificationHandler m
-> IdeNotificationHandler m
go DMap IdeNotification IdeNotificationHandler
a DMap IdeNotification IdeNotificationHandler
b
where
go :: p
-> IdeNotificationHandler m
-> IdeNotificationHandler m
-> IdeNotificationHandler m
go p
_ (IdeNotificationHandler [(PluginId, PluginDescriptor IdeState,
IdeState -> VFS -> MessageParams m -> LspT Config IO ())]
a) (IdeNotificationHandler [(PluginId, PluginDescriptor IdeState,
IdeState -> VFS -> MessageParams m -> LspT Config IO ())]
b) = forall (m :: Method 'FromClient 'Notification).
[(PluginId, PluginDescriptor IdeState,
IdeState -> VFS -> MessageParams m -> LspT Config IO ())]
-> IdeNotificationHandler m
IdeNotificationHandler ([(PluginId, PluginDescriptor IdeState,
IdeState -> VFS -> MessageParams m -> LspT Config IO ())]
a forall a. Semigroup a => a -> a -> a
<> [(PluginId, PluginDescriptor IdeState,
IdeState -> VFS -> MessageParams m -> LspT Config IO ())]
b)
instance Monoid IdeNotificationHandlers where
mempty :: IdeNotificationHandlers
mempty = DMap IdeNotification IdeNotificationHandler
-> IdeNotificationHandlers
IdeNotificationHandlers forall a. Monoid a => a
mempty