{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE GADTs             #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds         #-}

module Development.IDE.Plugin.HLS
    (
      asGhcIdePlugin
    , toResponseError
    , Log(..)
    ) where

import           Control.Exception             (SomeException)
import           Control.Monad
import           Control.Monad.Trans.Except    (runExceptT)
import qualified Data.Aeson                    as A
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           Ide.Logger
import           Ide.Plugin.Config
import           Ide.Plugin.Error
import           Ide.PluginUtils               (getClientConfig)
import           Ide.Types                     as HLS
import           Language.LSP.Protocol.Message
import           Language.LSP.Protocol.Types
import qualified Language.LSP.Server           as LSP
import           Language.LSP.VFS
import           Prettyprinter.Render.String   (renderString)
import           Text.Regex.TDFA.Text          ()
import           UnliftIO                      (MonadUnliftIO, liftIO)
import           UnliftIO.Async                (forConcurrently)
import           UnliftIO.Exception            (catchAny)

-- ---------------------------------------------------------------------
--

data Log
    =  LogPluginError PluginId PluginError
    | LogResponseError PluginId ResponseError
    | LogNoPluginForMethod (Some SMethod)
    | LogInvalidCommandIdentifier
    | ExceptionInPlugin PluginId (Some SMethod) SomeException

instance Pretty Log where
  pretty :: forall ann. Log -> Doc ann
pretty = \case
    LogPluginError (PluginId Text
pId) PluginError
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 ann. Pretty a => a -> Doc ann
pretty PluginError
err
    LogResponseError (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 ann. Pretty a => a -> Doc ann
pretty 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 SMethod a
method
    Log
LogInvalidCommandIdentifier-> Doc ann
"Invalid command identifier"
    ExceptionInPlugin PluginId
plId (Some SMethod a
method) SomeException
exception ->
        Doc ann
"Exception in plugin " forall a. Semigroup a => a -> a -> a
<> forall a ann. Show a => a -> Doc ann
viaShow PluginId
plId forall a. Semigroup a => a -> a -> a
<> Doc ann
" while processing "
          forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty SMethod a
method forall a. Semigroup a => a -> a -> a
<> Doc ann
": " forall a. Semigroup a => a -> a -> a
<> forall a ann. Show a => a -> Doc ann
viaShow SomeException
exception
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

noPluginEnabled :: Recorder (WithPriority Log) -> SMethod m -> [PluginId] -> IO (Either ResponseError c)
noPluginEnabled :: forall {f :: MessageDirection} {t :: MessageKind} (m :: Method f t)
       c.
Recorder (WithPriority Log)
-> SMethod m -> [PluginId] -> IO (Either ResponseError c)
noPluginEnabled Recorder (WithPriority Log)
recorder SMethod m
m [PluginId]
fs' = do
  forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Warning (forall {f :: MessageDirection} {t :: MessageKind}.
Some SMethod -> Log
LogNoPluginForMethod forall a b. (a -> b) -> a -> b
$ forall {k} (tag :: k -> *) (a :: k). tag a -> Some tag
Some SMethod m
m)
  let err :: ResponseError
err = (LSPErrorCodes |? ErrorCodes)
-> Text -> Maybe Value -> ResponseError
ResponseError (forall a b. b -> a |? b
InR ErrorCodes
ErrorCodes_MethodNotFound) Text
msg forall a. Maybe a
Nothing
      msg :: Text
msg = forall {f :: MessageDirection} {t :: MessageKind}
       (m :: Method f t).
SMethod m -> [PluginId] -> Text
pluginNotEnabled SMethod m
m [PluginId]
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
  where pluginNotEnabled :: SMethod m -> [PluginId] -> Text
        pluginNotEnabled :: forall {f :: MessageDirection} {t :: MessageKind}
       (m :: Method f t).
SMethod m -> [PluginId] -> Text
pluginNotEnabled SMethod m
method [PluginId]
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
", potentially 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) -> Text
plid) [PluginId]
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  -- ^ command that failed to parse
                    -> PluginId -- ^ Plugin that created the command
                    -> String   -- ^ The JSON Error message
                    -> A.Value  -- ^ The Argument Values
                    -> 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)

exceptionInPlugin :: PluginId -> SMethod m -> SomeException -> Text
exceptionInPlugin :: forall {f :: MessageDirection} {t :: MessageKind}
       (m :: Method f t).
PluginId -> SMethod m -> SomeException -> Text
exceptionInPlugin PluginId
plId SMethod m
method SomeException
exception =
    Text
"Exception in plugin " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall a. Show a => a -> String
show PluginId
plId) 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 m
method) 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
exception)

-- | Build a ResponseError and log it before returning to the caller
logAndReturnError :: Recorder (WithPriority Log) -> PluginId -> (LSPErrorCodes |? ErrorCodes) -> Text -> LSP.LspT Config IO (Either ResponseError a)
logAndReturnError :: forall a.
Recorder (WithPriority Log)
-> PluginId
-> (LSPErrorCodes |? ErrorCodes)
-> Text
-> LspT Config IO (Either ResponseError a)
logAndReturnError Recorder (WithPriority Log)
recorder PluginId
p LSPErrorCodes |? ErrorCodes
errCode Text
msg = do
    let err :: ResponseError
err = (LSPErrorCodes |? ErrorCodes)
-> Text -> Maybe Value -> ResponseError
ResponseError LSPErrorCodes |? ErrorCodes
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
LogResponseError 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

-- | Map a set of plugins to the underlying ghcide engine.
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
            -- 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
            [] -> 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 'ClientToServer 'Request) c.
PluginMethod 'Request m =>
SMethod m
-> (IdeState
    -> MessageParams m
    -> LspM c (Either ResponseError (MessageResult m)))
-> Handlers (ServerM c)
requestHandler SMethod 'Method_WorkspaceExecuteCommand
SMethod_WorkspaceExecuteCommand IdeState
-> ExecuteCommandParams
-> LspT Config IO (Either ResponseError (Value |? Null))
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

    -- The parameters to the HLS command are always the first element
    execCmd :: IdeState -> ExecuteCommandParams -> LSP.LspT Config IO (Either ResponseError (A.Value |? Null))
    execCmd :: IdeState
-> ExecuteCommandParams
-> LspT Config IO (Either ResponseError (Value |? Null))
execCmd IdeState
ide (ExecuteCommandParams Maybe ProgressToken
_ Text
cmdId Maybe [Value]
args) = do
      let cmdParams :: A.Value
          cmdParams :: Value
cmdParams = case Maybe [Value]
args of
            Just ((Value
x:[Value]
_)) -> Value
x
            Maybe [Value]
_            -> Value
A.Null
      case Text -> Maybe (PluginId, CommandId)
parseCmdId Text
cmdId of
        -- Shortcut for immediately applying a applyWorkspaceEdit as a fallback for v3.8 code actions
        Just (PluginId
"hls", CommandId
"fallbackCodeAction") ->
          case forall a. FromJSON a => Value -> Result a
A.fromJSON Value
cmdParams of
            A.Success (FallbackCodeActionParams Maybe WorkspaceEdit
mEdit Maybe Command
mCmd) -> do

              -- Send off the workspace request if it has one
              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 'ServerToClient 'Request) (f :: * -> *) config.
MonadLsp config f =>
SServerMethod m
-> MessageParams m
-> (Either ResponseError (MessageResult m) -> f ())
-> f (LspId m)
LSP.sendRequest SMethod 'Method_WorkspaceApplyEdit
SMethod_WorkspaceApplyEdit (Maybe Text -> WorkspaceEdit -> ApplyWorkspaceEditParams
ApplyWorkspaceEditParams forall a. Maybe a
Nothing WorkspaceEdit
edit) (\Either ResponseError (MessageResult 'Method_WorkspaceApplyEdit)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

              case Maybe Command
mCmd of
                -- If we have a command, continue to execute it
                Just (Command Text
_ Text
innerCmdId Maybe [Value]
innerArgs)
                    -> IdeState
-> ExecuteCommandParams
-> LspT Config IO (Either ResponseError (Value |? Null))
execCmd IdeState
ide (Maybe ProgressToken
-> Text -> Maybe [Value] -> ExecuteCommandParams
ExecuteCommandParams forall a. Maybe a
Nothing Text
innerCmdId Maybe [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 forall a b. (a -> b) -> a -> b
$ forall a b. b -> a |? b
InR Null
Null

            A.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 forall a b. (a -> b) -> a -> b
$ forall a b. b -> a |? b
InR Null
Null

        -- Just an ordinary HIE command
        Just (PluginId
plugin, CommandId
cmd) -> IdeState
-> PluginId
-> CommandId
-> Value
-> LspT Config IO (Either ResponseError (Value |? Null))
runPluginCommand IdeState
ide PluginId
plugin CommandId
cmd Value
cmdParams

        -- Couldn't parse the command identifier
        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
$ (LSPErrorCodes |? ErrorCodes)
-> Text -> Maybe Value -> ResponseError
ResponseError (forall a b. b -> a |? b
InR ErrorCodes
ErrorCodes_InvalidParams) Text
"Invalid command identifier" forall a. Maybe a
Nothing

    runPluginCommand :: IdeState -> PluginId -> CommandId -> A.Value -> LSP.LspT Config IO (Either ResponseError (A.Value |? Null))
    runPluginCommand :: IdeState
-> PluginId
-> CommandId
-> Value
-> LspT Config IO (Either ResponseError (Value |? Null))
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
-> (LSPErrorCodes |? ErrorCodes)
-> Text
-> LspT Config IO (Either ResponseError a)
logAndReturnError Recorder (WithPriority Log)
recorder PluginId
p (forall a b. b -> a |? b
InR ErrorCodes
ErrorCodes_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
-> (LSPErrorCodes |? ErrorCodes)
-> Text
-> LspT Config IO (Either ResponseError a)
logAndReturnError Recorder (WithPriority Log)
recorder PluginId
p (forall a b. b -> a |? b
InR ErrorCodes
ErrorCodes_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
A.fromJSON Value
arg of
            A.Error String
err -> forall a.
Recorder (WithPriority Log)
-> PluginId
-> (LSPErrorCodes |? ErrorCodes)
-> Text
-> LspT Config IO (Either ResponseError a)
logAndReturnError Recorder (WithPriority Log)
recorder PluginId
p (forall a b. b -> a |? b
InR ErrorCodes
ErrorCodes_InvalidParams) (CommandId -> PluginId -> String -> Value -> Text
failedToParseArgs CommandId
com PluginId
p String
err Value
arg)
            A.Success a
a -> do
              Either PluginError (Value |? Null)
res <- forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (CommandFunction IdeState a
f IdeState
ide a
a) forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`catchAny` -- See Note [Exception handling in plugins]
                (\SomeException
e -> 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
$ Text -> PluginError
PluginInternalError (forall {f :: MessageDirection} {t :: MessageKind}
       (m :: Method f t).
PluginId -> SMethod m -> SomeException -> Text
exceptionInPlugin PluginId
p SMethod 'Method_WorkspaceExecuteCommand
SMethod_WorkspaceExecuteCommand SomeException
e))
              case Either PluginError (Value |? Null)
res of
                (Left (PluginRequestRefused Text
_)) ->
                  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall {f :: MessageDirection} {t :: MessageKind} (m :: Method f t)
       c.
Recorder (WithPriority Log)
-> SMethod m -> [PluginId] -> IO (Either ResponseError c)
noPluginEnabled Recorder (WithPriority Log)
recorder SMethod 'Method_WorkspaceExecuteCommand
SMethod_WorkspaceExecuteCommand (forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(PluginId, [PluginCommand IdeState])]
ecs)
                (Left PluginError
pluginErr) -> do
                  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Recorder (WithPriority Log) -> [(PluginId, PluginError)] -> IO ()
logErrors Recorder (WithPriority Log)
recorder [(PluginId
p, PluginError
pluginErr)]
                  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
$ (PluginId, PluginError) -> ResponseError
toResponseError (PluginId
p, PluginError
pluginErr)
                (Right Value |? Null
result) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right Value |? Null
result

-- ---------------------------------------------------------------------

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)]
plugins = 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)]
plugins
    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 PluginError (MessageResult v)))
f) -> forall (m :: Method 'ClientToServer 'Request).
[(PluginId, PluginDescriptor IdeState,
  IdeState
  -> MessageParams m
  -> LspM Config (NonEmpty (Either PluginError (MessageResult m))))]
-> IdeHandler m
IdeHandler [(PluginId
pid,PluginDescriptor IdeState
pluginDesc,PluginId
-> IdeState
-> MessageParams v
-> LspM Config (NonEmpty (Either PluginError (MessageResult 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 PluginError (MessageResult 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 'ClientToServer 'Request) c.
PluginMethod 'Request m =>
SMethod m
-> (IdeState
    -> MessageParams m
    -> LspM c (Either ResponseError (MessageResult 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
        -- Only run plugins that are allowed to run on this request
        let fs :: [(PluginId, PluginDescriptor IdeState,
  IdeState
  -> MessageParams a
  -> LspM Config (NonEmpty (Either PluginError (MessageResult a))))]
fs = forall a. (a -> Bool) -> [a] -> [a]
filter (\(PluginId
_, PluginDescriptor IdeState
desc, IdeState
-> MessageParams a
-> LspM Config (NonEmpty (Either PluginError (MessageResult a)))
_) -> forall (k :: MessageKind) (m :: Method 'ClientToServer 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 PluginError (MessageResult a))))]
fs'
        -- Clients generally don't display ResponseErrors so instead we log any that we come across
        case forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [(PluginId, PluginDescriptor IdeState,
  IdeState
  -> MessageParams a
  -> LspM Config (NonEmpty (Either PluginError (MessageResult a))))]
fs of
          Maybe
  (NonEmpty
     (PluginId, PluginDescriptor IdeState,
      IdeState
      -> MessageParams a
      -> LspM Config (NonEmpty (Either PluginError (MessageResult a)))))
Nothing -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall {f :: MessageDirection} {t :: MessageKind} (m :: Method f t)
       c.
Recorder (WithPriority Log)
-> SMethod m -> [PluginId] -> IO (Either ResponseError c)
noPluginEnabled Recorder (WithPriority Log)
recorder SMethod a
m ((\(PluginId
x, PluginDescriptor IdeState
_, IdeState
-> MessageParams a
-> LspM Config (NonEmpty (Either PluginError (MessageResult a)))
_) -> PluginId
x) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(PluginId, PluginDescriptor IdeState,
  IdeState
  -> MessageParams a
  -> LspM Config (NonEmpty (Either PluginError (MessageResult a))))]
fs')
          Just NonEmpty
  (PluginId, PluginDescriptor IdeState,
   IdeState
   -> MessageParams a
   -> LspM Config (NonEmpty (Either PluginError (MessageResult a))))
neFs -> do
            let  plidsAndHandlers :: NonEmpty
  (PluginId,
   IdeState
   -> MessageParams a
   -> LspM Config (NonEmpty (Either PluginError (MessageResult a))))
plidsAndHandlers = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(PluginId
plid,PluginDescriptor IdeState
_,IdeState
-> MessageParams a
-> LspM Config (NonEmpty (Either PluginError (MessageResult a)))
handler) -> (PluginId
plid,IdeState
-> MessageParams a
-> LspM Config (NonEmpty (Either PluginError (MessageResult a)))
handler)) NonEmpty
  (PluginId, PluginDescriptor IdeState,
   IdeState
   -> MessageParams a
   -> LspM Config (NonEmpty (Either PluginError (MessageResult a))))
neFs
            NonEmpty (NonEmpty (Either PluginError (MessageResult a)))
es <- forall {f :: MessageDirection} {t :: MessageKind} (m :: * -> *)
       (method :: Method f t) a b d.
MonadUnliftIO m =>
(PluginId -> SMethod method -> SomeException -> Text)
-> SMethod method
-> NonEmpty
     (PluginId, a -> b -> m (NonEmpty (Either PluginError d)))
-> a
-> b
-> m (NonEmpty (NonEmpty (Either PluginError d)))
runConcurrently forall {f :: MessageDirection} {t :: MessageKind}
       (m :: Method f t).
PluginId -> SMethod m -> SomeException -> Text
exceptionInPlugin SMethod a
m NonEmpty
  (PluginId,
   IdeState
   -> MessageParams a
   -> LspM Config (NonEmpty (Either PluginError (MessageResult a))))
plidsAndHandlers IdeState
ide MessageParams a
params
            ClientCapabilities
caps <- forall config (m :: * -> *).
MonadLsp config m =>
m ClientCapabilities
LSP.getClientCapabilities
            let ([(PluginId, PluginError)]
errs,[MessageResult 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 PluginError (MessageResult 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 PluginError (MessageResult a))))
plidsAndHandlers NonEmpty (NonEmpty (Either PluginError (MessageResult a)))
es
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(PluginId, PluginError)]
errs) forall a b. (a -> b) -> a -> b
$ Recorder (WithPriority Log) -> [(PluginId, PluginError)] -> IO ()
logErrors Recorder (WithPriority Log)
recorder [(PluginId, PluginError)]
errs
            case forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [MessageResult a]
succs of
              Maybe (NonEmpty (MessageResult a))
Nothing -> do
                let noRefused :: (a, PluginError) -> Bool
noRefused (a
_, PluginRequestRefused Text
_) = Bool
False
                    noRefused (a
_, PluginError
_)                      = Bool
True
                    filteredErrs :: [(PluginId, PluginError)]
filteredErrs = forall a. (a -> Bool) -> [a] -> [a]
filter forall {a}. (a, PluginError) -> Bool
noRefused [(PluginId, PluginError)]
errs
                case forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [(PluginId, PluginError)]
filteredErrs of
                  Maybe (NonEmpty (PluginId, PluginError))
Nothing -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall {f :: MessageDirection} {t :: MessageKind} (m :: Method f t)
       c.
Recorder (WithPriority Log)
-> SMethod m -> [PluginId] -> IO (Either ResponseError c)
noPluginEnabled Recorder (WithPriority Log)
recorder SMethod a
m ((\(PluginId
x, PluginDescriptor IdeState
_, IdeState
-> MessageParams a
-> LspM Config (NonEmpty (Either PluginError (MessageResult a)))
_) -> PluginId
x) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(PluginId, PluginDescriptor IdeState,
  IdeState
  -> MessageParams a
  -> LspM Config (NonEmpty (Either PluginError (MessageResult a))))]
fs')
                  Just NonEmpty (PluginId, PluginError)
xs -> 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
$ NonEmpty (PluginId, PluginError) -> ResponseError
combineErrors NonEmpty (PluginId, PluginError)
xs
              Just NonEmpty (MessageResult a)
xs -> do
                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 'ClientToServer 'Request).
PluginRequestMethod m =>
SMethod m
-> Config
-> ClientCapabilities
-> MessageParams m
-> NonEmpty (MessageResult m)
-> MessageResult m
combineResponses SMethod a
m Config
config ClientCapabilities
caps MessageParams a
params NonEmpty (MessageResult 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 'ClientToServer '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 'ClientToServer 'Notification) c.
PluginMethod 'Notification 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
        -- Only run plugins that are allowed to run on this request
        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 :: MessageKind) (m :: Method 'ClientToServer 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 :: MessageDirection} {t :: MessageKind}.
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 ())
neFs -> do
            -- We run the notifications in order, so the core ghcide provider
            -- (which restarts the shake process) hopefully comes last
            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
                                    forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`catchAny` -- See Note [Exception handling in plugins]
                                    (\SomeException
e -> forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Warning (forall {f :: MessageDirection} {t :: MessageKind}.
PluginId -> Some SMethod -> SomeException -> Log
ExceptionInPlugin PluginId
pid (forall {k} (tag :: k -> *) (a :: k). tag a -> Some tag
Some SMethod a
m) SomeException
e))) NonEmpty
  (PluginId, PluginDescriptor IdeState,
   IdeState -> VFS -> MessageParams a -> LspT Config IO ())
neFs


-- ---------------------------------------------------------------------

runConcurrently
  :: MonadUnliftIO m
  => (PluginId -> SMethod method -> SomeException -> T.Text)
  -> SMethod method -- ^ Method (used for errors and tracing)
  -> NonEmpty (PluginId, a -> b -> m (NonEmpty (Either PluginError d)))
  -- ^ Enabled plugin actions that we are allowed to run
  -> a
  -> b
  -> m (NonEmpty(NonEmpty (Either PluginError d)))
runConcurrently :: forall {f :: MessageDirection} {t :: MessageKind} (m :: * -> *)
       (method :: Method f t) a b d.
MonadUnliftIO m =>
(PluginId -> SMethod method -> SomeException -> Text)
-> SMethod method
-> NonEmpty
     (PluginId, a -> b -> m (NonEmpty (Either PluginError d)))
-> a
-> b
-> m (NonEmpty (NonEmpty (Either PluginError d)))
runConcurrently PluginId -> SMethod method -> SomeException -> Text
msg SMethod method
method NonEmpty (PluginId, a -> b -> m (NonEmpty (Either PluginError 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 PluginError d)))
fs forall a b. (a -> b) -> a -> b
$ \(PluginId
pid,a -> b -> m (NonEmpty (Either PluginError d))
f) -> forall (m :: * -> *) a.
MonadUnliftIO m =>
PluginId -> ByteString -> m a -> m a
otTracedProvider PluginId
pid (forall a. IsString a => String -> a
fromString (forall a. Show a => a -> String
show SMethod method
method)) forall a b. (a -> b) -> a -> b
$ do
  a -> b -> m (NonEmpty (Either PluginError d))
f a
a b
b  -- See Note [Exception handling in plugins]
     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
$ Text -> PluginError
PluginInternalError (PluginId -> SMethod method -> SomeException -> Text
msg PluginId
pid SMethod method
method SomeException
e))

combineErrors :: NonEmpty (PluginId, PluginError) -> ResponseError
combineErrors :: NonEmpty (PluginId, PluginError) -> ResponseError
combineErrors ((PluginId, PluginError)
x NE.:| []) = (PluginId, PluginError) -> ResponseError
toResponseError (PluginId, PluginError)
x
combineErrors NonEmpty (PluginId, PluginError)
xs = (PluginId, PluginError) -> ResponseError
toResponseError forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> a
NE.last forall a b. (a -> b) -> a -> b
$ forall o a. Ord o => (a -> o) -> NonEmpty a -> NonEmpty a
NE.sortWith (PluginError -> Priority
toPriority forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) NonEmpty (PluginId, PluginError)
xs

toResponseError :: (PluginId, PluginError) -> ResponseError
toResponseError :: (PluginId, PluginError) -> ResponseError
toResponseError (PluginId Text
plId, PluginError
err) =
        (LSPErrorCodes |? ErrorCodes)
-> Text -> Maybe Value -> ResponseError
ResponseError (PluginError -> LSPErrorCodes |? ErrorCodes
toErrorCode PluginError
err) (Text
plId forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> PluginError -> Text
tPretty PluginError
err) forall a. Maybe a
Nothing
    where tPretty :: PluginError -> Text
tPretty = String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a ann. Pretty a => a -> Doc ann
pretty

logErrors :: Recorder (WithPriority Log) -> [(PluginId, PluginError)] -> IO ()
logErrors :: Recorder (WithPriority Log) -> [(PluginId, PluginError)] -> IO ()
logErrors Recorder (WithPriority Log)
recorder [(PluginId, PluginError)]
errs = do
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(PluginId, PluginError)]
errs forall a b. (a -> b) -> a -> b
$ \(PluginId
pId, PluginError
err) ->
                PluginId -> PluginError -> IO ()
logIndividualErrors PluginId
pId PluginError
err
  where logIndividualErrors :: PluginId -> PluginError -> IO ()
logIndividualErrors PluginId
plId PluginError
err =
          forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder (PluginError -> Priority
toPriority PluginError
err) forall a b. (a -> b) -> a -> b
$ PluginId -> PluginError -> Log
LogPluginError PluginId
plId PluginError
err


-- | Combine the 'PluginHandler' for all plugins
newtype IdeHandler (m :: Method ClientToServer Request)
  = IdeHandler [(PluginId, PluginDescriptor IdeState, IdeState -> MessageParams m -> LSP.LspM Config (NonEmpty (Either PluginError (MessageResult m))))]

-- | Combine the 'PluginHandler' for all plugins
newtype IdeNotificationHandler (m :: Method ClientToServer Notification)
  = IdeNotificationHandler [(PluginId, PluginDescriptor IdeState, IdeState -> VFS -> MessageParams m -> LSP.LspM Config ())]
-- type NotificationHandler (m :: Method ClientToServer Notification) = MessageParams m -> IO ()`

-- | Combine the 'PluginHandlers' for all plugins
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 'ClientToServer 'Request}
       {m :: Method 'ClientToServer 'Request}
       {m :: Method 'ClientToServer 'Request} {p}.
(MessageResult m ~ MessageResult m,
 MessageResult m ~ MessageResult 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 PluginError (MessageResult m))))]
c) (IdeHandler [(PluginId, PluginDescriptor IdeState,
  IdeState
  -> MessageParams m
  -> LspM Config (NonEmpty (Either PluginError (MessageResult m))))]
d) = forall (m :: Method 'ClientToServer 'Request).
[(PluginId, PluginDescriptor IdeState,
  IdeState
  -> MessageParams m
  -> LspM Config (NonEmpty (Either PluginError (MessageResult m))))]
-> IdeHandler m
IdeHandler ([(PluginId, PluginDescriptor IdeState,
  IdeState
  -> MessageParams m
  -> LspM Config (NonEmpty (Either PluginError (MessageResult m))))]
c forall a. Semigroup a => a -> a -> a
<> [(PluginId, PluginDescriptor IdeState,
  IdeState
  -> MessageParams m
  -> LspM Config (NonEmpty (Either PluginError (MessageResult m))))]
d)
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 'ClientToServer 'Notification}
       {m :: Method 'ClientToServer 'Notification}
       {m :: Method 'ClientToServer '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 ())]
c) (IdeNotificationHandler [(PluginId, PluginDescriptor IdeState,
  IdeState -> VFS -> MessageParams m -> LspT Config IO ())]
d) = forall (m :: Method 'ClientToServer 'Notification).
[(PluginId, PluginDescriptor IdeState,
  IdeState -> VFS -> MessageParams m -> LspT Config IO ())]
-> IdeNotificationHandler m
IdeNotificationHandler ([(PluginId, PluginDescriptor IdeState,
  IdeState -> VFS -> MessageParams m -> LspT Config IO ())]
c forall a. Semigroup a => a -> a -> a
<> [(PluginId, PluginDescriptor IdeState,
  IdeState -> VFS -> MessageParams m -> LspT Config IO ())]
d)
instance Monoid IdeNotificationHandlers where
  mempty :: IdeNotificationHandlers
mempty = DMap IdeNotification IdeNotificationHandler
-> IdeNotificationHandlers
IdeNotificationHandlers forall a. Monoid a => a
mempty

{- Note [Exception handling in plugins]
Plugins run in LspM, and so have access to IO. This means they are likely to
throw exceptions, even if only by accident or through calling libraries that
throw exceptions. Ultimately, we're running a bunch of less-trusted IO code,
so we should be robust to it throwing.

We don't want these to bring down HLS. So we catch and log exceptions wherever
we run a handler defined in a plugin.

The flip side of this is that it's okay for plugins to throw exceptions as a
way of signalling failure!
-}