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

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.Maybe                    (mapMaybe)
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.Plugin.HandleRequestTypes
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
    | forall m . A.ToJSON (ErrorData m) => LogResponseError PluginId (TResponseError m)
    | 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 ->
      Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
pId Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
":" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> PluginError -> Doc ann
forall ann. PluginError -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty PluginError
err
    LogResponseError (PluginId Text
pId) TResponseError m
err ->
      Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
pId Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
":" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> TResponseError m -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. TResponseError m -> Doc ann
pretty TResponseError m
err
    LogNoPluginForMethod (Some SMethod a
method) ->
        Doc ann
"No plugin handles this " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> SMethod a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. SMethod a -> Doc ann
pretty SMethod a
method Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
" request."
    Log
LogInvalidCommandIdentifier-> Doc ann
"Invalid command identifier"
    ExceptionInPlugin PluginId
plId (Some SMethod a
method) SomeException
exception ->
        Doc ann
"Exception in plugin " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> PluginId -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow PluginId
plId Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
" while processing "
          Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> SMethod a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. SMethod a -> Doc ann
pretty SMethod a
method Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
": " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> SomeException -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow SomeException
exception
instance Show Log where show :: Log -> String
show = SimpleDocStream Any -> String
forall ann. SimpleDocStream ann -> String
renderString (SimpleDocStream Any -> String)
-> (Log -> SimpleDocStream Any) -> Log -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc Any -> SimpleDocStream Any
forall ann1 ann2. Doc ann1 -> SimpleDocStream ann2
layoutCompact (Doc Any -> SimpleDocStream Any)
-> (Log -> Doc Any) -> Log -> SimpleDocStream Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Log -> Doc Any
forall a ann. Pretty a => a -> Doc ann
forall ann. Log -> Doc ann
pretty

noPluginHandles :: Recorder (WithPriority Log) -> SMethod m -> [(PluginId, HandleRequestResult)] -> IO (Either (TResponseError m) c)
noPluginHandles :: forall {f :: MessageDirection} (m :: Method f 'Request) c.
Recorder (WithPriority Log)
-> SMethod m
-> [(PluginId, HandleRequestResult)]
-> IO (Either (TResponseError m) c)
noPluginHandles Recorder (WithPriority Log)
recorder SMethod m
m [(PluginId, HandleRequestResult)]
fs' = do
  Recorder (WithPriority Log) -> Priority -> Log -> IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Warning (Some SMethod -> Log
forall {f :: MessageDirection} {t :: MessageKind}.
Some SMethod -> Log
LogNoPluginForMethod (Some SMethod -> Log) -> Some SMethod -> Log
forall a b. (a -> b) -> a -> b
$ SMethod m -> Some SMethod
forall {k} (tag :: k -> *) (a :: k). tag a -> Some tag
Some SMethod m
m)
  let err :: TResponseError m
err = (LSPErrorCodes |? ErrorCodes)
-> Text -> Maybe (ErrorData m) -> TResponseError m
forall (f :: MessageDirection) (m :: Method f 'Request).
(LSPErrorCodes |? ErrorCodes)
-> Text -> Maybe (ErrorData m) -> TResponseError m
TResponseError (ErrorCodes -> LSPErrorCodes |? ErrorCodes
forall a b. b -> a |? b
InR ErrorCodes
ErrorCodes_MethodNotFound) Text
msg Maybe (ErrorData m)
forall a. Maybe a
Nothing
      msg :: Text
msg = SMethod m -> [(PluginId, HandleRequestResult)] -> Text
forall {f :: MessageDirection} {t :: MessageKind}
       (m :: Method f t).
SMethod m -> [(PluginId, HandleRequestResult)] -> Text
noPluginHandlesMsg SMethod m
m [(PluginId, HandleRequestResult)]
fs'
  Either (TResponseError m) c -> IO (Either (TResponseError m) c)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (TResponseError m) c -> IO (Either (TResponseError m) c))
-> Either (TResponseError m) c -> IO (Either (TResponseError m) c)
forall a b. (a -> b) -> a -> b
$ TResponseError m -> Either (TResponseError m) c
forall a b. a -> Either a b
Left TResponseError m
err
  where noPluginHandlesMsg :: SMethod m -> [(PluginId, HandleRequestResult)] -> Text
        noPluginHandlesMsg :: forall {f :: MessageDirection} {t :: MessageKind}
       (m :: Method f t).
SMethod m -> [(PluginId, HandleRequestResult)] -> Text
noPluginHandlesMsg SMethod m
method [] = Text
"No plugins are available to handle this " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (SMethod m -> String
forall a. Show a => a -> String
show SMethod m
method) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" request."
        noPluginHandlesMsg SMethod m
method [(PluginId, HandleRequestResult)]
availPlugins =
            Text
"No plugins are available to handle this " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (SMethod m -> String
forall a. Show a => a -> String
show SMethod m
method) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" request.\n Plugins installed for this method, but not available to handle this request are:\n"
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Text -> [Text] -> Text
T.intercalate Text
"\n" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
                      ((PluginId, HandleRequestResult) -> Text)
-> [(PluginId, HandleRequestResult)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (\(PluginId Text
plid, HandleRequestResult
pluginStatus) ->
                              Text
plid
                              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" "
                              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (SimpleDocStream Any -> Text
forall ann. SimpleDocStream ann -> Text
renderStrict (SimpleDocStream Any -> Text)
-> (HandleRequestResult -> SimpleDocStream Any)
-> HandleRequestResult
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc Any -> SimpleDocStream Any
forall ann1 ann2. Doc ann1 -> SimpleDocStream ann2
layoutCompact (Doc Any -> SimpleDocStream Any)
-> (HandleRequestResult -> Doc Any)
-> HandleRequestResult
-> SimpleDocStream Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandleRequestResult -> Doc Any
forall ann. HandleRequestResult -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty) HandleRequestResult
pluginStatus)
                          [(PluginId, HandleRequestResult)]
availPlugins)

pluginDoesntExist :: PluginId -> Text
pluginDoesntExist :: PluginId -> Text
pluginDoesntExist (PluginId Text
pid) = Text
"Plugin " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pid Text -> Text -> Text
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 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
com Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" isn't defined for plugin " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pid Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
". Legal commands are: "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Text -> [Text] -> Text
T.intercalate Text
", " ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (PluginCommand ideState -> Text)
-> [PluginCommand ideState] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (\(PluginCommand{$sel:commandId:PluginCommand :: 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 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
com Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" in plugin " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pid Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
err Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", arg = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Value -> String
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 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (PluginId -> String
forall a. Show a => a -> String
show PluginId
plId) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" while processing "Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (SMethod m -> String
forall a. Show a => a -> String
show SMethod m
method) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (SomeException -> String
forall a. Show a => a -> String
show SomeException
exception)

-- | Build a ResponseError and log it before returning to the caller
logAndReturnError :: A.ToJSON (ErrorData m) => Recorder (WithPriority Log) -> PluginId -> (LSPErrorCodes |? ErrorCodes) -> Text -> LSP.LspT Config IO (Either (TResponseError m) a)
logAndReturnError :: forall {f :: MessageDirection} (m :: Method f 'Request) a.
ToJSON (ErrorData m) =>
Recorder (WithPriority Log)
-> PluginId
-> (LSPErrorCodes |? ErrorCodes)
-> Text
-> LspT Config IO (Either (TResponseError m) a)
logAndReturnError Recorder (WithPriority Log)
recorder PluginId
p LSPErrorCodes |? ErrorCodes
errCode Text
msg = do
    let err :: TResponseError m
err = (LSPErrorCodes |? ErrorCodes)
-> Text -> Maybe (ErrorData m) -> TResponseError m
forall (f :: MessageDirection) (m :: Method f 'Request).
(LSPErrorCodes |? ErrorCodes)
-> Text -> Maybe (ErrorData m) -> TResponseError m
TResponseError LSPErrorCodes |? ErrorCodes
errCode Text
msg Maybe (ErrorData m)
forall a. Maybe a
Nothing
    Recorder (WithPriority Log) -> Priority -> Log -> LspT Config IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Warning (Log -> LspT Config IO ()) -> Log -> LspT Config IO ()
forall a b. (a -> b) -> a -> b
$ PluginId -> TResponseError m -> Log
forall {f :: MessageDirection} (m :: Method f 'Request).
ToJSON (ErrorData m) =>
PluginId -> TResponseError m -> Log
LogResponseError PluginId
p TResponseError m
err
    Either (TResponseError m) a
-> LspT Config IO (Either (TResponseError m) a)
forall a. a -> LspT Config IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (TResponseError m) a
 -> LspT Config IO (Either (TResponseError m) a))
-> Either (TResponseError m) a
-> LspT Config IO (Either (TResponseError m) a)
forall a b. (a -> b) -> a -> b
$ TResponseError m -> Either (TResponseError m) a
forall a b. a -> Either a b
Left TResponseError m
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) =
    ([(PluginId, Rules ())] -> Plugin Config)
-> (PluginDescriptor IdeState -> Rules ()) -> Plugin Config
forall {b}.
([(PluginId, b)] -> Plugin Config)
-> (PluginDescriptor IdeState -> b) -> Plugin Config
mkPlugin [(PluginId, Rules ())] -> Plugin Config
rulesPlugins PluginDescriptor IdeState -> Rules ()
forall ideState. PluginDescriptor ideState -> Rules ()
HLS.pluginRules Plugin Config -> Plugin Config -> Plugin Config
forall a. Semigroup a => a -> a -> a
<>
    ([(PluginId, [PluginCommand IdeState])] -> Plugin Config)
-> (PluginDescriptor IdeState -> [PluginCommand IdeState])
-> Plugin Config
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) PluginDescriptor IdeState -> [PluginCommand IdeState]
forall ideState.
PluginDescriptor ideState -> [PluginCommand ideState]
HLS.pluginCommands Plugin Config -> Plugin Config -> Plugin Config
forall a. Semigroup a => a -> a -> a
<>
    ([(PluginId, PluginDescriptor IdeState)] -> Plugin Config)
-> (PluginDescriptor IdeState -> PluginDescriptor IdeState)
-> Plugin Config
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) PluginDescriptor IdeState -> PluginDescriptor IdeState
forall a. a -> a
id Plugin Config -> Plugin Config -> Plugin Config
forall a. Semigroup a => a -> a -> a
<>
    ([(PluginId, PluginDescriptor IdeState)] -> Plugin Config)
-> (PluginDescriptor IdeState -> PluginDescriptor IdeState)
-> Plugin Config
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) PluginDescriptor IdeState -> PluginDescriptor IdeState
forall a. a -> a
id Plugin Config -> Plugin Config -> Plugin Config
forall a. Semigroup a => a -> a -> a
<>
    ([(PluginDescriptor IdeState, DynFlagsModifications)]
 -> Plugin Config)
-> (PluginDescriptor IdeState -> DynFlagsModifications)
-> Plugin Config
forall b.
([(PluginDescriptor IdeState, b)] -> Plugin Config)
-> (PluginDescriptor IdeState -> b) -> Plugin Config
mkPluginFromDescriptor [(PluginDescriptor IdeState, DynFlagsModifications)]
-> Plugin Config
forall c.
[(PluginDescriptor c, DynFlagsModifications)] -> Plugin Config
dynFlagsPlugins PluginDescriptor IdeState -> DynFlagsModifications
forall ideState. PluginDescriptor ideState -> DynFlagsModifications
HLS.pluginModifyDynflags
    where
        mkPlugin :: ([(PluginId, b)] -> Plugin Config)
-> (PluginDescriptor IdeState -> b) -> Plugin Config
mkPlugin [(PluginId, b)] -> Plugin Config
f = ([(PluginDescriptor IdeState, b)] -> Plugin Config)
-> (PluginDescriptor IdeState -> b) -> Plugin Config
forall b.
([(PluginDescriptor IdeState, b)] -> Plugin Config)
-> (PluginDescriptor IdeState -> b) -> Plugin Config
mkPluginFromDescriptor ([(PluginId, b)] -> Plugin Config
f ([(PluginId, b)] -> Plugin Config)
-> ([(PluginDescriptor IdeState, b)] -> [(PluginId, b)])
-> [(PluginDescriptor IdeState, b)]
-> Plugin Config
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((PluginDescriptor IdeState, b) -> (PluginId, b))
-> [(PluginDescriptor IdeState, b)] -> [(PluginId, b)]
forall a b. (a -> b) -> [a] -> [b]
map ((PluginDescriptor IdeState -> PluginId)
-> (PluginDescriptor IdeState, b) -> (PluginId, b)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first PluginDescriptor IdeState -> PluginId
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 (PluginDescriptor IdeState -> (PluginDescriptor IdeState, b))
-> [PluginDescriptor IdeState] -> [(PluginDescriptor IdeState, b)]
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
            [] -> Plugin Config
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 = Plugin Config
forall a. Monoid a => a
mempty { P.pluginRules = rules }
    where
        rules :: Rules ()
rules = ((PluginId, Rules ()) -> Rules ())
-> [(PluginId, Rules ())] -> Rules ()
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (PluginId, Rules ()) -> Rules ()
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 = Plugin Config
forall a. Monoid a => a
mempty
  { P.pluginModifyDynflags =
      flip foldMap rs $ \(PluginDescriptor c
plId, DynFlagsModifications
dflag_mods) Config
cfg ->
        let plg_cfg :: PluginConfig
plg_cfg = Config -> PluginDescriptor c -> PluginConfig
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 DynFlagsModifications
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 = Plugin Config
forall a. Monoid a => a
mempty { P.pluginHandlers = executeCommandHandlers recorder 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 = SMethod 'Method_WorkspaceExecuteCommand
-> (IdeState
    -> MessageParams 'Method_WorkspaceExecuteCommand
    -> LspM
         Config
         (Either
            (TResponseError 'Method_WorkspaceExecuteCommand)
            (MessageResult 'Method_WorkspaceExecuteCommand)))
-> Handlers (ServerM Config)
forall (m :: Method 'ClientToServer 'Request) c.
PluginMethod 'Request m =>
SMethod m
-> (IdeState
    -> MessageParams m
    -> LspM c (Either (TResponseError m) (MessageResult m)))
-> Handlers (ServerM c)
requestHandler SMethod 'Method_WorkspaceExecuteCommand
SMethod_WorkspaceExecuteCommand IdeState
-> ExecuteCommandParams
-> LspT
     Config
     IO
     (Either
        (TResponseError 'Method_WorkspaceExecuteCommand) (Value |? Null))
IdeState
-> MessageParams 'Method_WorkspaceExecuteCommand
-> LspM
     Config
     (Either
        (TResponseError 'Method_WorkspaceExecuteCommand)
        (MessageResult 'Method_WorkspaceExecuteCommand))
execCmd
  where
    pluginMap :: Map PluginId [PluginCommand IdeState]
pluginMap = ([PluginCommand IdeState]
 -> [PluginCommand IdeState] -> [PluginCommand IdeState])
-> [(PluginId, [PluginCommand IdeState])]
-> Map PluginId [PluginCommand IdeState]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [PluginCommand IdeState]
-> [PluginCommand IdeState] -> [PluginCommand IdeState]
forall a. [a] -> [a] -> [a]
(++) [(PluginId, [PluginCommand IdeState])]
ecs

    parseCmdId :: T.Text -> Maybe (PluginId, CommandId)
    parseCmdId :: Text -> Maybe (PluginId, CommandId)
parseCmdId Text
x = case HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
":" Text
x of
      [Text
plugin, Text
command]    -> (PluginId, CommandId) -> Maybe (PluginId, CommandId)
forall a. a -> Maybe a
Just (Text -> PluginId
PluginId Text
plugin, Text -> CommandId
CommandId Text
command)
      [Text
_, Text
plugin, Text
command] -> (PluginId, CommandId) -> Maybe (PluginId, CommandId)
forall a. a -> Maybe a
Just (Text -> PluginId
PluginId Text
plugin, Text -> CommandId
CommandId Text
command)
      [Text]
_                    -> Maybe (PluginId, CommandId)
forall a. Maybe a
Nothing

    -- The parameters to the HLS command are always the first element
    execCmd :: IdeState -> ExecuteCommandParams -> LSP.LspT Config IO (Either (TResponseError Method_WorkspaceExecuteCommand) (A.Value |? Null))
    execCmd :: IdeState
-> ExecuteCommandParams
-> LspT
     Config
     IO
     (Either
        (TResponseError 'Method_WorkspaceExecuteCommand) (Value |? Null))
execCmd IdeState
ide (ExecuteCommandParams Maybe ProgressToken
mtoken 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 Value -> Result FallbackCodeActionParams
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
              Maybe WorkspaceEdit
-> (WorkspaceEdit
    -> LspT Config IO (LspId 'Method_WorkspaceApplyEdit))
-> LspT Config IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe WorkspaceEdit
mEdit ((WorkspaceEdit
  -> LspT Config IO (LspId 'Method_WorkspaceApplyEdit))
 -> LspT Config IO ())
-> (WorkspaceEdit
    -> LspT Config IO (LspId 'Method_WorkspaceApplyEdit))
-> LspT Config IO ()
forall a b. (a -> b) -> a -> b
$ \WorkspaceEdit
edit ->
                SServerMethod 'Method_WorkspaceApplyEdit
-> MessageParams 'Method_WorkspaceApplyEdit
-> (Either
      (TResponseError 'Method_WorkspaceApplyEdit)
      (MessageResult 'Method_WorkspaceApplyEdit)
    -> LspT Config IO ())
-> LspT Config IO (LspId 'Method_WorkspaceApplyEdit)
forall (m :: Method 'ServerToClient 'Request) (f :: * -> *) config.
MonadLsp config f =>
SServerMethod m
-> MessageParams m
-> (Either (TResponseError m) (MessageResult m) -> f ())
-> f (LspId m)
LSP.sendRequest SServerMethod 'Method_WorkspaceApplyEdit
SMethod_WorkspaceApplyEdit (Maybe Text -> WorkspaceEdit -> ApplyWorkspaceEditParams
ApplyWorkspaceEditParams Maybe Text
forall a. Maybe a
Nothing WorkspaceEdit
edit) (\Either
  (TResponseError 'Method_WorkspaceApplyEdit)
  (MessageResult 'Method_WorkspaceApplyEdit)
_ -> () -> LspT Config IO ()
forall a. a -> LspT Config IO a
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
        (TResponseError 'Method_WorkspaceExecuteCommand) (Value |? Null))
execCmd IdeState
ide (Maybe ProgressToken
-> Text -> Maybe [Value] -> ExecuteCommandParams
ExecuteCommandParams Maybe ProgressToken
forall a. Maybe a
Nothing Text
innerCmdId Maybe [Value]
innerArgs)
                -- TODO: This should be a response error?
                Maybe Command
Nothing -> Either
  (TResponseError 'Method_WorkspaceExecuteCommand) (Value |? Null)
-> LspT
     Config
     IO
     (Either
        (TResponseError 'Method_WorkspaceExecuteCommand) (Value |? Null))
forall a. a -> LspT Config IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
   (TResponseError 'Method_WorkspaceExecuteCommand) (Value |? Null)
 -> LspT
      Config
      IO
      (Either
         (TResponseError 'Method_WorkspaceExecuteCommand) (Value |? Null)))
-> Either
     (TResponseError 'Method_WorkspaceExecuteCommand) (Value |? Null)
-> LspT
     Config
     IO
     (Either
        (TResponseError 'Method_WorkspaceExecuteCommand) (Value |? Null))
forall a b. (a -> b) -> a -> b
$ (Value |? Null)
-> Either
     (TResponseError 'Method_WorkspaceExecuteCommand) (Value |? Null)
forall a b. b -> Either a b
Right ((Value |? Null)
 -> Either
      (TResponseError 'Method_WorkspaceExecuteCommand) (Value |? Null))
-> (Value |? Null)
-> Either
     (TResponseError 'Method_WorkspaceExecuteCommand) (Value |? Null)
forall a b. (a -> b) -> a -> b
$ Null -> Value |? Null
forall a b. b -> a |? b
InR Null
Null

            -- TODO: This should be a response error?
            A.Error String
_str -> Either
  (TResponseError 'Method_WorkspaceExecuteCommand) (Value |? Null)
-> LspT
     Config
     IO
     (Either
        (TResponseError 'Method_WorkspaceExecuteCommand) (Value |? Null))
forall a. a -> LspT Config IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
   (TResponseError 'Method_WorkspaceExecuteCommand) (Value |? Null)
 -> LspT
      Config
      IO
      (Either
         (TResponseError 'Method_WorkspaceExecuteCommand) (Value |? Null)))
-> Either
     (TResponseError 'Method_WorkspaceExecuteCommand) (Value |? Null)
-> LspT
     Config
     IO
     (Either
        (TResponseError 'Method_WorkspaceExecuteCommand) (Value |? Null))
forall a b. (a -> b) -> a -> b
$ (Value |? Null)
-> Either
     (TResponseError 'Method_WorkspaceExecuteCommand) (Value |? Null)
forall a b. b -> Either a b
Right ((Value |? Null)
 -> Either
      (TResponseError 'Method_WorkspaceExecuteCommand) (Value |? Null))
-> (Value |? Null)
-> Either
     (TResponseError 'Method_WorkspaceExecuteCommand) (Value |? Null)
forall a b. (a -> b) -> a -> b
$ Null -> Value |? Null
forall a b. b -> a |? b
InR Null
Null

        -- Just an ordinary HIE command
        Just (PluginId
plugin, CommandId
cmd) -> IdeState
-> PluginId
-> CommandId
-> Maybe ProgressToken
-> Value
-> LspT
     Config
     IO
     (Either
        (TResponseError 'Method_WorkspaceExecuteCommand) (Value |? Null))
runPluginCommand IdeState
ide PluginId
plugin CommandId
cmd Maybe ProgressToken
mtoken Value
cmdParams

        -- Couldn't parse the command identifier
        Maybe (PluginId, CommandId)
_ -> do
            Recorder (WithPriority Log) -> Priority -> Log -> LspT Config IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Warning Log
LogInvalidCommandIdentifier
            Either
  (TResponseError 'Method_WorkspaceExecuteCommand) (Value |? Null)
-> LspT
     Config
     IO
     (Either
        (TResponseError 'Method_WorkspaceExecuteCommand) (Value |? Null))
forall a. a -> LspT Config IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
   (TResponseError 'Method_WorkspaceExecuteCommand) (Value |? Null)
 -> LspT
      Config
      IO
      (Either
         (TResponseError 'Method_WorkspaceExecuteCommand) (Value |? Null)))
-> Either
     (TResponseError 'Method_WorkspaceExecuteCommand) (Value |? Null)
-> LspT
     Config
     IO
     (Either
        (TResponseError 'Method_WorkspaceExecuteCommand) (Value |? Null))
forall a b. (a -> b) -> a -> b
$ TResponseError 'Method_WorkspaceExecuteCommand
-> Either
     (TResponseError 'Method_WorkspaceExecuteCommand) (Value |? Null)
forall a b. a -> Either a b
Left (TResponseError 'Method_WorkspaceExecuteCommand
 -> Either
      (TResponseError 'Method_WorkspaceExecuteCommand) (Value |? Null))
-> TResponseError 'Method_WorkspaceExecuteCommand
-> Either
     (TResponseError 'Method_WorkspaceExecuteCommand) (Value |? Null)
forall a b. (a -> b) -> a -> b
$ (LSPErrorCodes |? ErrorCodes)
-> Text
-> Maybe (ErrorData 'Method_WorkspaceExecuteCommand)
-> TResponseError 'Method_WorkspaceExecuteCommand
forall (f :: MessageDirection) (m :: Method f 'Request).
(LSPErrorCodes |? ErrorCodes)
-> Text -> Maybe (ErrorData m) -> TResponseError m
TResponseError (ErrorCodes -> LSPErrorCodes |? ErrorCodes
forall a b. b -> a |? b
InR ErrorCodes
ErrorCodes_InvalidParams) Text
"Invalid command identifier" Maybe (Maybe Void)
Maybe (ErrorData 'Method_WorkspaceExecuteCommand)
forall a. Maybe a
Nothing

    runPluginCommand :: IdeState -> PluginId -> CommandId -> Maybe ProgressToken -> A.Value -> LSP.LspT Config IO (Either (TResponseError Method_WorkspaceExecuteCommand) (A.Value |? Null))
    runPluginCommand :: IdeState
-> PluginId
-> CommandId
-> Maybe ProgressToken
-> Value
-> LspT
     Config
     IO
     (Either
        (TResponseError 'Method_WorkspaceExecuteCommand) (Value |? Null))
runPluginCommand IdeState
ide PluginId
p CommandId
com Maybe ProgressToken
mtoken Value
arg =
      case PluginId
-> Map PluginId [PluginCommand IdeState]
-> Maybe [PluginCommand IdeState]
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 -> Recorder (WithPriority Log)
-> PluginId
-> (LSPErrorCodes |? ErrorCodes)
-> Text
-> LspT
     Config
     IO
     (Either
        (TResponseError 'Method_WorkspaceExecuteCommand) (Value |? Null))
forall {f :: MessageDirection} (m :: Method f 'Request) a.
ToJSON (ErrorData m) =>
Recorder (WithPriority Log)
-> PluginId
-> (LSPErrorCodes |? ErrorCodes)
-> Text
-> LspT Config IO (Either (TResponseError m) a)
logAndReturnError Recorder (WithPriority Log)
recorder PluginId
p (ErrorCodes -> LSPErrorCodes |? ErrorCodes
forall a b. b -> a |? b
InR ErrorCodes
ErrorCodes_InvalidRequest) (PluginId -> Text
pluginDoesntExist PluginId
p)
        Just [PluginCommand IdeState]
xs -> case (PluginCommand IdeState -> Bool)
-> [PluginCommand IdeState] -> Maybe (PluginCommand IdeState)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find ((CommandId
com ==) (CommandId -> Bool)
-> (PluginCommand IdeState -> CommandId)
-> PluginCommand IdeState
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PluginCommand IdeState -> CommandId
forall ideState. PluginCommand ideState -> CommandId
commandId) [PluginCommand IdeState]
xs of
          Maybe (PluginCommand IdeState)
Nothing -> Recorder (WithPriority Log)
-> PluginId
-> (LSPErrorCodes |? ErrorCodes)
-> Text
-> LspT
     Config
     IO
     (Either
        (TResponseError 'Method_WorkspaceExecuteCommand) (Value |? Null))
forall {f :: MessageDirection} (m :: Method f 'Request) a.
ToJSON (ErrorData m) =>
Recorder (WithPriority Log)
-> PluginId
-> (LSPErrorCodes |? ErrorCodes)
-> Text
-> LspT Config IO (Either (TResponseError m) a)
logAndReturnError Recorder (WithPriority Log)
recorder PluginId
p (ErrorCodes -> LSPErrorCodes |? ErrorCodes
forall a b. b -> a |? b
InR ErrorCodes
ErrorCodes_InvalidRequest) (CommandId -> PluginId -> [PluginCommand IdeState] -> Text
forall ideState.
CommandId -> PluginId -> [PluginCommand ideState] -> Text
commandDoesntExist CommandId
com PluginId
p [PluginCommand IdeState]
xs)
          Just (PluginCommand CommandId
_ Text
_ CommandFunction IdeState a
f) -> case Value -> Result a
forall a. FromJSON a => Value -> Result a
A.fromJSON Value
arg of
            A.Error String
err -> Recorder (WithPriority Log)
-> PluginId
-> (LSPErrorCodes |? ErrorCodes)
-> Text
-> LspT
     Config
     IO
     (Either
        (TResponseError 'Method_WorkspaceExecuteCommand) (Value |? Null))
forall {f :: MessageDirection} (m :: Method f 'Request) a.
ToJSON (ErrorData m) =>
Recorder (WithPriority Log)
-> PluginId
-> (LSPErrorCodes |? ErrorCodes)
-> Text
-> LspT Config IO (Either (TResponseError m) a)
logAndReturnError Recorder (WithPriority Log)
recorder PluginId
p (ErrorCodes -> LSPErrorCodes |? ErrorCodes
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 <- HandlerM Config (Either PluginError (Value |? Null))
-> LspM Config (Either PluginError (Value |? Null))
forall config a. HandlerM config a -> LspM config a
runHandlerM (ExceptT PluginError (HandlerM Config) (Value |? Null)
-> HandlerM Config (Either PluginError (Value |? Null))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (CommandFunction IdeState a
f IdeState
ide Maybe ProgressToken
mtoken a
a)) LspM Config (Either PluginError (Value |? Null))
-> (SomeException
    -> LspM Config (Either PluginError (Value |? Null)))
-> LspM Config (Either PluginError (Value |? Null))
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`catchAny` -- See Note [Exception handling in plugins]
                (\SomeException
e -> Either PluginError (Value |? Null)
-> LspM Config (Either PluginError (Value |? Null))
forall a. a -> LspT Config IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either PluginError (Value |? Null)
 -> LspM Config (Either PluginError (Value |? Null)))
-> Either PluginError (Value |? Null)
-> LspM Config (Either PluginError (Value |? Null))
forall a b. (a -> b) -> a -> b
$ PluginError -> Either PluginError (Value |? Null)
forall a b. a -> Either a b
Left (PluginError -> Either PluginError (Value |? Null))
-> PluginError -> Either PluginError (Value |? Null)
forall a b. (a -> b) -> a -> b
$ Text -> PluginError
PluginInternalError (PluginId
-> SMethod 'Method_WorkspaceExecuteCommand -> SomeException -> Text
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 RejectionReason
r)) ->
                  IO
  (Either
     (TResponseError 'Method_WorkspaceExecuteCommand) (Value |? Null))
-> LspT
     Config
     IO
     (Either
        (TResponseError 'Method_WorkspaceExecuteCommand) (Value |? Null))
forall a. IO a -> LspT Config IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO
   (Either
      (TResponseError 'Method_WorkspaceExecuteCommand) (Value |? Null))
 -> LspT
      Config
      IO
      (Either
         (TResponseError 'Method_WorkspaceExecuteCommand) (Value |? Null)))
-> IO
     (Either
        (TResponseError 'Method_WorkspaceExecuteCommand) (Value |? Null))
-> LspT
     Config
     IO
     (Either
        (TResponseError 'Method_WorkspaceExecuteCommand) (Value |? Null))
forall a b. (a -> b) -> a -> b
$ Recorder (WithPriority Log)
-> SMethod 'Method_WorkspaceExecuteCommand
-> [(PluginId, HandleRequestResult)]
-> IO
     (Either
        (TResponseError 'Method_WorkspaceExecuteCommand) (Value |? Null))
forall {f :: MessageDirection} (m :: Method f 'Request) c.
Recorder (WithPriority Log)
-> SMethod m
-> [(PluginId, HandleRequestResult)]
-> IO (Either (TResponseError m) c)
noPluginHandles Recorder (WithPriority Log)
recorder SMethod 'Method_WorkspaceExecuteCommand
SMethod_WorkspaceExecuteCommand [(PluginId
p,RejectionReason -> HandleRequestResult
DoesNotHandleRequest RejectionReason
r)]
                (Left PluginError
pluginErr) -> do
                  IO () -> LspT Config IO ()
forall a. IO a -> LspT Config IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> LspT Config IO ()) -> IO () -> LspT Config IO ()
forall a b. (a -> b) -> a -> b
$ Recorder (WithPriority Log) -> [(PluginId, PluginError)] -> IO ()
logErrors Recorder (WithPriority Log)
recorder [(PluginId
p, PluginError
pluginErr)]
                  Either
  (TResponseError 'Method_WorkspaceExecuteCommand) (Value |? Null)
-> LspT
     Config
     IO
     (Either
        (TResponseError 'Method_WorkspaceExecuteCommand) (Value |? Null))
forall a. a -> LspT Config IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either
   (TResponseError 'Method_WorkspaceExecuteCommand) (Value |? Null)
 -> LspT
      Config
      IO
      (Either
         (TResponseError 'Method_WorkspaceExecuteCommand) (Value |? Null)))
-> Either
     (TResponseError 'Method_WorkspaceExecuteCommand) (Value |? Null)
-> LspT
     Config
     IO
     (Either
        (TResponseError 'Method_WorkspaceExecuteCommand) (Value |? Null))
forall a b. (a -> b) -> a -> b
$ TResponseError 'Method_WorkspaceExecuteCommand
-> Either
     (TResponseError 'Method_WorkspaceExecuteCommand) (Value |? Null)
forall a b. a -> Either a b
Left (TResponseError 'Method_WorkspaceExecuteCommand
 -> Either
      (TResponseError 'Method_WorkspaceExecuteCommand) (Value |? Null))
-> TResponseError 'Method_WorkspaceExecuteCommand
-> Either
     (TResponseError 'Method_WorkspaceExecuteCommand) (Value |? Null)
forall a b. (a -> b) -> a -> b
$ (PluginId, PluginError)
-> TResponseError 'Method_WorkspaceExecuteCommand
forall {f :: MessageDirection} (m :: Method f 'Request).
(PluginId, PluginError) -> TResponseError m
toResponseError (PluginId
p, PluginError
pluginErr)
                (Right Value |? Null
result) -> Either
  (TResponseError 'Method_WorkspaceExecuteCommand) (Value |? Null)
-> LspT
     Config
     IO
     (Either
        (TResponseError 'Method_WorkspaceExecuteCommand) (Value |? Null))
forall a. a -> LspT Config IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either
   (TResponseError 'Method_WorkspaceExecuteCommand) (Value |? Null)
 -> LspT
      Config
      IO
      (Either
         (TResponseError 'Method_WorkspaceExecuteCommand) (Value |? Null)))
-> Either
     (TResponseError 'Method_WorkspaceExecuteCommand) (Value |? Null)
-> LspT
     Config
     IO
     (Either
        (TResponseError 'Method_WorkspaceExecuteCommand) (Value |? Null))
forall a b. (a -> b) -> a -> b
$ (Value |? Null)
-> Either
     (TResponseError 'Method_WorkspaceExecuteCommand) (Value |? Null)
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 = Plugin Config
forall a. Monoid a => a
mempty { P.pluginHandlers = handlers }
  where
    IdeHandlers DMap IdeMethod IdeHandler
handlers' = ((PluginId, PluginDescriptor IdeState) -> IdeHandlers)
-> [(PluginId, PluginDescriptor IdeState)] -> IdeHandlers
forall m a. Monoid m => (a -> m) -> [a] -> m
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 (DMap IdeMethod IdeHandler -> IdeHandlers)
-> DMap IdeMethod IdeHandler -> IdeHandlers
forall a b. (a -> b) -> a -> b
$ (forall (v :: Method 'ClientToServer 'Request).
 PluginHandler IdeState v -> IdeHandler v)
-> DMap IdeMethod (PluginHandler IdeState)
-> DMap IdeMethod IdeHandler
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
-> HandlerM
     Config (NonEmpty (Either PluginError (MessageResult v)))
f) -> [(PluginId, PluginDescriptor IdeState,
  IdeState
  -> MessageParams v
  -> HandlerM
       Config (NonEmpty (Either PluginError (MessageResult v))))]
-> IdeHandler v
forall (m :: Method 'ClientToServer 'Request).
[(PluginId, PluginDescriptor IdeState,
  IdeState
  -> MessageParams m
  -> HandlerM
       Config (NonEmpty (Either PluginError (MessageResult m))))]
-> IdeHandler m
IdeHandler [(PluginId
pid,PluginDescriptor IdeState
pluginDesc,PluginId
-> IdeState
-> MessageParams v
-> HandlerM
     Config (NonEmpty (Either PluginError (MessageResult v)))
f PluginId
pid)])
      DMap IdeMethod (PluginHandler IdeState)
hs
      where
        PluginHandlers DMap IdeMethod (PluginHandler IdeState)
hs = PluginDescriptor IdeState -> PluginHandlers IdeState
forall ideState.
PluginDescriptor ideState -> PluginHandlers ideState
HLS.pluginHandlers PluginDescriptor IdeState
pluginDesc
    handlers :: Handlers (ServerM Config)
handlers = [Handlers (ServerM Config)] -> Handlers (ServerM Config)
forall a. Monoid a => [a] -> a
mconcat ([Handlers (ServerM Config)] -> Handlers (ServerM Config))
-> [Handlers (ServerM Config)] -> Handlers (ServerM Config)
forall a b. (a -> b) -> a -> b
$ do
      (IdeMethod SMethod a
m :=> IdeHandler [(PluginId, PluginDescriptor IdeState,
  IdeState
  -> MessageParams a
  -> HandlerM
       Config (NonEmpty (Either PluginError (MessageResult a))))]
fs') <- DMap IdeMethod IdeHandler -> [DSum IdeMethod IdeHandler]
forall {k1} (k2 :: k1 -> *) (f :: k1 -> *).
DMap k2 f -> [DSum k2 f]
DMap.assocs DMap IdeMethod IdeHandler
handlers'
      Handlers (ServerM Config) -> [Handlers (ServerM Config)]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Handlers (ServerM Config) -> [Handlers (ServerM Config)])
-> Handlers (ServerM Config) -> [Handlers (ServerM Config)]
forall a b. (a -> b) -> a -> b
$ SMethod a
-> (IdeState
    -> MessageParams a
    -> LspM Config (Either (TResponseError a) (MessageResult a)))
-> Handlers (ServerM Config)
forall (m :: Method 'ClientToServer 'Request) c.
PluginMethod 'Request m =>
SMethod m
-> (IdeState
    -> MessageParams m
    -> LspM c (Either (TResponseError m) (MessageResult m)))
-> Handlers (ServerM c)
requestHandler SMethod a
m ((IdeState
  -> MessageParams a
  -> LspM Config (Either (TResponseError a) (MessageResult a)))
 -> Handlers (ServerM Config))
-> (IdeState
    -> MessageParams a
    -> LspM Config (Either (TResponseError a) (MessageResult a)))
-> Handlers (ServerM Config)
forall a b. (a -> b) -> a -> b
$ \IdeState
ide MessageParams a
params -> do
        Config
config <- LspT Config IO Config
forall (m :: * -> *). MonadLsp Config m => m Config
Ide.PluginUtils.getClientConfig
        -- Only run plugins that are allowed to run on this request, save the
        -- list of disabled plugins incase that's all we have
        let ([(PluginId, PluginDescriptor IdeState,
  IdeState
  -> MessageParams a
  -> HandlerM
       Config (NonEmpty (Either PluginError (MessageResult a))))]
fs, [(PluginId, PluginDescriptor IdeState,
  IdeState
  -> MessageParams a
  -> HandlerM
       Config (NonEmpty (Either PluginError (MessageResult a))))]
dfs) = ((PluginId, PluginDescriptor IdeState,
  IdeState
  -> MessageParams a
  -> HandlerM
       Config (NonEmpty (Either PluginError (MessageResult a))))
 -> Bool)
-> [(PluginId, PluginDescriptor IdeState,
     IdeState
     -> MessageParams a
     -> HandlerM
          Config (NonEmpty (Either PluginError (MessageResult a))))]
-> ([(PluginId, PluginDescriptor IdeState,
      IdeState
      -> MessageParams a
      -> HandlerM
           Config (NonEmpty (Either PluginError (MessageResult a))))],
    [(PluginId, PluginDescriptor IdeState,
      IdeState
      -> MessageParams a
      -> HandlerM
           Config (NonEmpty (Either PluginError (MessageResult a))))])
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition (\(PluginId
_, PluginDescriptor IdeState
desc, IdeState
-> MessageParams a
-> HandlerM
     Config (NonEmpty (Either PluginError (MessageResult a)))
_) -> SMethod a
-> MessageParams a
-> PluginDescriptor IdeState
-> Config
-> HandleRequestResult
forall c.
SMethod a
-> MessageParams a
-> PluginDescriptor c
-> Config
-> HandleRequestResult
forall (k :: MessageKind) (m :: Method 'ClientToServer k) c.
PluginMethod k m =>
SMethod m
-> MessageParams m
-> PluginDescriptor c
-> Config
-> HandleRequestResult
handlesRequest SMethod a
m MessageParams a
params PluginDescriptor IdeState
desc Config
config HandleRequestResult -> HandleRequestResult -> Bool
forall a. Eq a => a -> a -> Bool
== HandleRequestResult
HandlesRequest) [(PluginId, PluginDescriptor IdeState,
  IdeState
  -> MessageParams a
  -> HandlerM
       Config (NonEmpty (Either PluginError (MessageResult a))))]
fs'
        let disabledPluginsReason :: [(PluginId, HandleRequestResult)]
disabledPluginsReason = (\(PluginId
x, PluginDescriptor IdeState
desc, IdeState
-> MessageParams a
-> HandlerM
     Config (NonEmpty (Either PluginError (MessageResult a)))
_) -> (PluginId
x, SMethod a
-> MessageParams a
-> PluginDescriptor IdeState
-> Config
-> HandleRequestResult
forall c.
SMethod a
-> MessageParams a
-> PluginDescriptor c
-> Config
-> HandleRequestResult
forall (k :: MessageKind) (m :: Method 'ClientToServer k) c.
PluginMethod k m =>
SMethod m
-> MessageParams m
-> PluginDescriptor c
-> Config
-> HandleRequestResult
handlesRequest SMethod a
m MessageParams a
params PluginDescriptor IdeState
desc Config
config)) ((PluginId, PluginDescriptor IdeState,
  IdeState
  -> MessageParams a
  -> HandlerM
       Config (NonEmpty (Either PluginError (MessageResult a))))
 -> (PluginId, HandleRequestResult))
-> [(PluginId, PluginDescriptor IdeState,
     IdeState
     -> MessageParams a
     -> HandlerM
          Config (NonEmpty (Either PluginError (MessageResult a))))]
-> [(PluginId, HandleRequestResult)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(PluginId, PluginDescriptor IdeState,
  IdeState
  -> MessageParams a
  -> HandlerM
       Config (NonEmpty (Either PluginError (MessageResult a))))]
dfs
        -- Clients generally don't display ResponseErrors so instead we log any that we come across
        case [(PluginId, PluginDescriptor IdeState,
  IdeState
  -> MessageParams a
  -> HandlerM
       Config (NonEmpty (Either PluginError (MessageResult a))))]
-> Maybe
     (NonEmpty
        (PluginId, PluginDescriptor IdeState,
         IdeState
         -> MessageParams a
         -> HandlerM
              Config (NonEmpty (Either PluginError (MessageResult a)))))
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [(PluginId, PluginDescriptor IdeState,
  IdeState
  -> MessageParams a
  -> HandlerM
       Config (NonEmpty (Either PluginError (MessageResult a))))]
fs of
          Maybe
  (NonEmpty
     (PluginId, PluginDescriptor IdeState,
      IdeState
      -> MessageParams a
      -> HandlerM
           Config (NonEmpty (Either PluginError (MessageResult a)))))
Nothing -> IO (Either (TResponseError a) (MessageResult a))
-> LspM Config (Either (TResponseError a) (MessageResult a))
forall a. IO a -> LspT Config IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either (TResponseError a) (MessageResult a))
 -> LspM Config (Either (TResponseError a) (MessageResult a)))
-> IO (Either (TResponseError a) (MessageResult a))
-> LspM Config (Either (TResponseError a) (MessageResult a))
forall a b. (a -> b) -> a -> b
$ Recorder (WithPriority Log)
-> SMethod a
-> [(PluginId, HandleRequestResult)]
-> IO (Either (TResponseError a) (MessageResult a))
forall {f :: MessageDirection} (m :: Method f 'Request) c.
Recorder (WithPriority Log)
-> SMethod m
-> [(PluginId, HandleRequestResult)]
-> IO (Either (TResponseError m) c)
noPluginHandles Recorder (WithPriority Log)
recorder SMethod a
m [(PluginId, HandleRequestResult)]
disabledPluginsReason
          Just NonEmpty
  (PluginId, PluginDescriptor IdeState,
   IdeState
   -> MessageParams a
   -> HandlerM
        Config (NonEmpty (Either PluginError (MessageResult a))))
neFs -> do
            let  plidsAndHandlers :: NonEmpty
  (PluginId,
   IdeState
   -> MessageParams a
   -> HandlerM
        Config (NonEmpty (Either PluginError (MessageResult a))))
plidsAndHandlers = ((PluginId, PluginDescriptor IdeState,
  IdeState
  -> MessageParams a
  -> HandlerM
       Config (NonEmpty (Either PluginError (MessageResult a))))
 -> (PluginId,
     IdeState
     -> MessageParams a
     -> HandlerM
          Config (NonEmpty (Either PluginError (MessageResult a)))))
-> NonEmpty
     (PluginId, PluginDescriptor IdeState,
      IdeState
      -> MessageParams a
      -> HandlerM
           Config (NonEmpty (Either PluginError (MessageResult a))))
-> NonEmpty
     (PluginId,
      IdeState
      -> MessageParams a
      -> HandlerM
           Config (NonEmpty (Either PluginError (MessageResult a))))
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(PluginId
plid,PluginDescriptor IdeState
_,IdeState
-> MessageParams a
-> HandlerM
     Config (NonEmpty (Either PluginError (MessageResult a)))
handler) -> (PluginId
plid,IdeState
-> MessageParams a
-> HandlerM
     Config (NonEmpty (Either PluginError (MessageResult a)))
handler)) NonEmpty
  (PluginId, PluginDescriptor IdeState,
   IdeState
   -> MessageParams a
   -> HandlerM
        Config (NonEmpty (Either PluginError (MessageResult a))))
neFs
            NonEmpty (NonEmpty (Either PluginError (MessageResult a)))
es <- HandlerM
  Config (NonEmpty (NonEmpty (Either PluginError (MessageResult a))))
-> LspM
     Config (NonEmpty (NonEmpty (Either PluginError (MessageResult a))))
forall config a. HandlerM config a -> LspM config a
runHandlerM (HandlerM
   Config (NonEmpty (NonEmpty (Either PluginError (MessageResult a))))
 -> LspM
      Config
      (NonEmpty (NonEmpty (Either PluginError (MessageResult a)))))
-> HandlerM
     Config (NonEmpty (NonEmpty (Either PluginError (MessageResult a))))
-> LspM
     Config (NonEmpty (NonEmpty (Either PluginError (MessageResult a))))
forall a b. (a -> b) -> a -> b
$ (PluginId -> SMethod a -> SomeException -> Text)
-> SMethod a
-> NonEmpty
     (PluginId,
      IdeState
      -> MessageParams a
      -> HandlerM
           Config (NonEmpty (Either PluginError (MessageResult a))))
-> IdeState
-> MessageParams a
-> HandlerM
     Config (NonEmpty (NonEmpty (Either PluginError (MessageResult a))))
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 a -> SomeException -> Text
forall {f :: MessageDirection} {t :: MessageKind}
       (m :: Method f t).
PluginId -> SMethod m -> SomeException -> Text
exceptionInPlugin SMethod a
m NonEmpty
  (PluginId,
   IdeState
   -> MessageParams a
   -> HandlerM
        Config (NonEmpty (Either PluginError (MessageResult a))))
plidsAndHandlers IdeState
ide MessageParams a
params
            ClientCapabilities
caps <- LspT Config IO ClientCapabilities
forall config (m :: * -> *).
MonadLsp config m =>
m ClientCapabilities
LSP.getClientCapabilities
            let ([(PluginId, PluginError)]
errs,[MessageResult a]
succs) = [Either (PluginId, PluginError) (MessageResult a)]
-> ([(PluginId, PluginError)], [MessageResult a])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either (PluginId, PluginError) (MessageResult a)]
 -> ([(PluginId, PluginError)], [MessageResult a]))
-> [Either (PluginId, PluginError) (MessageResult a)]
-> ([(PluginId, PluginError)], [MessageResult a])
forall a b. (a -> b) -> a -> b
$ NonEmpty (Either (PluginId, PluginError) (MessageResult a))
-> [Either (PluginId, PluginError) (MessageResult a)]
forall a. NonEmpty a -> [a]
toList (NonEmpty (Either (PluginId, PluginError) (MessageResult a))
 -> [Either (PluginId, PluginError) (MessageResult a)])
-> NonEmpty (Either (PluginId, PluginError) (MessageResult a))
-> [Either (PluginId, PluginError) (MessageResult a)]
forall a b. (a -> b) -> a -> b
$ NonEmpty
  (NonEmpty (Either (PluginId, PluginError) (MessageResult a)))
-> NonEmpty (Either (PluginId, PluginError) (MessageResult a))
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (NonEmpty
   (NonEmpty (Either (PluginId, PluginError) (MessageResult a)))
 -> NonEmpty (Either (PluginId, PluginError) (MessageResult a)))
-> NonEmpty
     (NonEmpty (Either (PluginId, PluginError) (MessageResult a)))
-> NonEmpty (Either (PluginId, PluginError) (MessageResult a))
forall a b. (a -> b) -> a -> b
$ ((PluginId,
  IdeState
  -> MessageParams a
  -> HandlerM
       Config (NonEmpty (Either PluginError (MessageResult a))))
 -> NonEmpty (Either PluginError (MessageResult a))
 -> NonEmpty (Either (PluginId, PluginError) (MessageResult a)))
-> NonEmpty
     (PluginId,
      IdeState
      -> MessageParams a
      -> HandlerM
           Config (NonEmpty (Either PluginError (MessageResult a))))
-> NonEmpty (NonEmpty (Either PluginError (MessageResult a)))
-> NonEmpty
     (NonEmpty (Either (PluginId, PluginError) (MessageResult a)))
forall a b c.
(a -> b -> c) -> NonEmpty a -> NonEmpty b -> NonEmpty c
NE.zipWith (\(PluginId
pId,IdeState
-> MessageParams a
-> HandlerM
     Config (NonEmpty (Either PluginError (MessageResult a)))
_) -> (Either PluginError (MessageResult a)
 -> Either (PluginId, PluginError) (MessageResult a))
-> NonEmpty (Either PluginError (MessageResult a))
-> NonEmpty (Either (PluginId, PluginError) (MessageResult a))
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((PluginError -> (PluginId, PluginError))
-> Either PluginError (MessageResult a)
-> Either (PluginId, PluginError) (MessageResult a)
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (PluginId
pId,))) NonEmpty
  (PluginId,
   IdeState
   -> MessageParams a
   -> HandlerM
        Config (NonEmpty (Either PluginError (MessageResult a))))
plidsAndHandlers NonEmpty (NonEmpty (Either PluginError (MessageResult a)))
es
            IO () -> LspT Config IO ()
forall a. IO a -> LspT Config IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> LspT Config IO ()) -> IO () -> LspT Config IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([(PluginId, PluginError)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(PluginId, PluginError)]
errs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Recorder (WithPriority Log) -> [(PluginId, PluginError)] -> IO ()
logErrors Recorder (WithPriority Log)
recorder [(PluginId, PluginError)]
errs
            case [MessageResult a] -> Maybe (NonEmpty (MessageResult a))
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 RejectionReason
_) = Bool
False
                    noRefused (a
_, PluginError
_)                      = Bool
True
                    ([(PluginId, PluginError)]
asErrors, [(PluginId, PluginError)]
asRefused) = ((PluginId, PluginError) -> Bool)
-> [(PluginId, PluginError)]
-> ([(PluginId, PluginError)], [(PluginId, PluginError)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition (PluginId, PluginError) -> Bool
forall {a}. (a, PluginError) -> Bool
noRefused [(PluginId, PluginError)]
errs
                    convertPRR :: (a, PluginError) -> Maybe (a, HandleRequestResult)
convertPRR (a
pId, PluginRequestRefused RejectionReason
r) = (a, HandleRequestResult) -> Maybe (a, HandleRequestResult)
forall a. a -> Maybe a
Just (a
pId, RejectionReason -> HandleRequestResult
DoesNotHandleRequest RejectionReason
r)
                    convertPRR (a, PluginError)
_ = Maybe (a, HandleRequestResult)
forall a. Maybe a
Nothing
                    asRefusedReason :: [(PluginId, HandleRequestResult)]
asRefusedReason = ((PluginId, PluginError) -> Maybe (PluginId, HandleRequestResult))
-> [(PluginId, PluginError)] -> [(PluginId, HandleRequestResult)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (PluginId, PluginError) -> Maybe (PluginId, HandleRequestResult)
forall {a}. (a, PluginError) -> Maybe (a, HandleRequestResult)
convertPRR [(PluginId, PluginError)]
asRefused
                case [(PluginId, PluginError)]
-> Maybe (NonEmpty (PluginId, PluginError))
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [(PluginId, PluginError)]
asErrors of
                  Maybe (NonEmpty (PluginId, PluginError))
Nothing -> IO (Either (TResponseError a) (MessageResult a))
-> LspM Config (Either (TResponseError a) (MessageResult a))
forall a. IO a -> LspT Config IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either (TResponseError a) (MessageResult a))
 -> LspM Config (Either (TResponseError a) (MessageResult a)))
-> IO (Either (TResponseError a) (MessageResult a))
-> LspM Config (Either (TResponseError a) (MessageResult a))
forall a b. (a -> b) -> a -> b
$ Recorder (WithPriority Log)
-> SMethod a
-> [(PluginId, HandleRequestResult)]
-> IO (Either (TResponseError a) (MessageResult a))
forall {f :: MessageDirection} (m :: Method f 'Request) c.
Recorder (WithPriority Log)
-> SMethod m
-> [(PluginId, HandleRequestResult)]
-> IO (Either (TResponseError m) c)
noPluginHandles Recorder (WithPriority Log)
recorder SMethod a
m  ([(PluginId, HandleRequestResult)]
disabledPluginsReason [(PluginId, HandleRequestResult)]
-> [(PluginId, HandleRequestResult)]
-> [(PluginId, HandleRequestResult)]
forall a. Semigroup a => a -> a -> a
<> [(PluginId, HandleRequestResult)]
asRefusedReason)
                  Just NonEmpty (PluginId, PluginError)
xs -> Either (TResponseError a) (MessageResult a)
-> LspM Config (Either (TResponseError a) (MessageResult a))
forall a. a -> LspT Config IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (TResponseError a) (MessageResult a)
 -> LspM Config (Either (TResponseError a) (MessageResult a)))
-> Either (TResponseError a) (MessageResult a)
-> LspM Config (Either (TResponseError a) (MessageResult a))
forall a b. (a -> b) -> a -> b
$ TResponseError a -> Either (TResponseError a) (MessageResult a)
forall a b. a -> Either a b
Left (TResponseError a -> Either (TResponseError a) (MessageResult a))
-> TResponseError a -> Either (TResponseError a) (MessageResult a)
forall a b. (a -> b) -> a -> b
$ NonEmpty (PluginId, PluginError) -> TResponseError a
forall {f :: MessageDirection} (m :: Method f 'Request).
NonEmpty (PluginId, PluginError) -> TResponseError m
combineErrors NonEmpty (PluginId, PluginError)
xs
              Just NonEmpty (MessageResult a)
xs -> do
                Either (TResponseError a) (MessageResult a)
-> LspM Config (Either (TResponseError a) (MessageResult a))
forall a. a -> LspT Config IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (TResponseError a) (MessageResult a)
 -> LspM Config (Either (TResponseError a) (MessageResult a)))
-> Either (TResponseError a) (MessageResult a)
-> LspM Config (Either (TResponseError a) (MessageResult a))
forall a b. (a -> b) -> a -> b
$ MessageResult a -> Either (TResponseError a) (MessageResult a)
forall a b. b -> Either a b
Right (MessageResult a -> Either (TResponseError a) (MessageResult a))
-> MessageResult a -> Either (TResponseError a) (MessageResult a)
forall a b. (a -> b) -> a -> b
$ SMethod a
-> Config
-> ClientCapabilities
-> MessageParams a
-> NonEmpty (MessageResult a)
-> MessageResult a
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 = Plugin Config
forall a. Monoid a => a
mempty { P.pluginHandlers = handlers }
  where
    IdeNotificationHandlers DMap IdeNotification IdeNotificationHandler
handlers' = ((PluginId, PluginDescriptor IdeState) -> IdeNotificationHandlers)
-> [(PluginId, PluginDescriptor IdeState)]
-> IdeNotificationHandlers
forall m a. Monoid m => (a -> m) -> [a] -> m
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 (DMap IdeNotification IdeNotificationHandler
 -> IdeNotificationHandlers)
-> DMap IdeNotification IdeNotificationHandler
-> IdeNotificationHandlers
forall a b. (a -> b) -> a -> b
$ (forall (v :: Method 'ClientToServer 'Notification).
 PluginNotificationHandler IdeState v -> IdeNotificationHandler v)
-> DMap IdeNotification (PluginNotificationHandler IdeState)
-> DMap IdeNotification IdeNotificationHandler
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) -> [(PluginId, PluginDescriptor IdeState,
  IdeState -> VFS -> MessageParams v -> LspT Config IO ())]
-> IdeNotificationHandler v
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 = PluginDescriptor IdeState -> PluginNotificationHandlers IdeState
forall ideState.
PluginDescriptor ideState -> PluginNotificationHandlers ideState
HLS.pluginNotificationHandlers PluginDescriptor IdeState
pluginDesc
    handlers :: Handlers (ServerM Config)
handlers = [Handlers (ServerM Config)] -> Handlers (ServerM Config)
forall a. Monoid a => [a] -> a
mconcat ([Handlers (ServerM Config)] -> Handlers (ServerM Config))
-> [Handlers (ServerM Config)] -> Handlers (ServerM Config)
forall a b. (a -> b) -> a -> b
$ do
      (IdeNotification SMethod a
m :=> IdeNotificationHandler [(PluginId, PluginDescriptor IdeState,
  IdeState -> VFS -> MessageParams a -> LspT Config IO ())]
fs') <- DMap IdeNotification IdeNotificationHandler
-> [DSum IdeNotification IdeNotificationHandler]
forall {k1} (k2 :: k1 -> *) (f :: k1 -> *).
DMap k2 f -> [DSum k2 f]
DMap.assocs DMap IdeNotification IdeNotificationHandler
handlers'
      Handlers (ServerM Config) -> [Handlers (ServerM Config)]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Handlers (ServerM Config) -> [Handlers (ServerM Config)])
-> Handlers (ServerM Config) -> [Handlers (ServerM Config)]
forall a b. (a -> b) -> a -> b
$ SMethod a
-> (IdeState -> VFS -> MessageParams a -> LspT Config IO ())
-> Handlers (ServerM Config)
forall (m :: Method 'ClientToServer 'Notification) c.
PluginMethod 'Notification m =>
SMethod m
-> (IdeState -> VFS -> MessageParams m -> LspM c ())
-> Handlers (ServerM c)
notificationHandler SMethod a
m ((IdeState -> VFS -> MessageParams a -> LspT Config IO ())
 -> Handlers (ServerM Config))
-> (IdeState -> VFS -> MessageParams a -> LspT Config IO ())
-> Handlers (ServerM Config)
forall a b. (a -> b) -> a -> b
$ \IdeState
ide VFS
vfs MessageParams a
params -> do
        Config
config <- LspT Config IO Config
forall (m :: * -> *). MonadLsp Config m => m Config
Ide.PluginUtils.getClientConfig
        -- Only run plugins that are enabled for this request
        let fs :: [(PluginId, PluginDescriptor IdeState,
  IdeState -> VFS -> MessageParams a -> LspT Config IO ())]
fs = ((PluginId, PluginDescriptor IdeState,
  IdeState -> VFS -> MessageParams a -> LspT Config IO ())
 -> Bool)
-> [(PluginId, PluginDescriptor IdeState,
     IdeState -> VFS -> MessageParams a -> LspT Config IO ())]
-> [(PluginId, PluginDescriptor IdeState,
     IdeState -> VFS -> MessageParams a -> LspT Config IO ())]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(PluginId
_, PluginDescriptor IdeState
desc, IdeState -> VFS -> MessageParams a -> LspT Config IO ()
_) -> SMethod a
-> MessageParams a
-> PluginDescriptor IdeState
-> Config
-> HandleRequestResult
forall c.
SMethod a
-> MessageParams a
-> PluginDescriptor c
-> Config
-> HandleRequestResult
forall (k :: MessageKind) (m :: Method 'ClientToServer k) c.
PluginMethod k m =>
SMethod m
-> MessageParams m
-> PluginDescriptor c
-> Config
-> HandleRequestResult
handlesRequest SMethod a
m MessageParams a
params PluginDescriptor IdeState
desc Config
config HandleRequestResult -> HandleRequestResult -> Bool
forall a. Eq a => a -> a -> Bool
== HandleRequestResult
HandlesRequest) [(PluginId, PluginDescriptor IdeState,
  IdeState -> VFS -> MessageParams a -> LspT Config IO ())]
fs'
        case [(PluginId, PluginDescriptor IdeState,
  IdeState -> VFS -> MessageParams a -> LspT Config IO ())]
-> Maybe
     (NonEmpty
        (PluginId, PluginDescriptor IdeState,
         IdeState -> VFS -> MessageParams a -> LspT Config IO ()))
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
            Recorder (WithPriority Log) -> Priority -> Log -> LspT Config IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Warning (Some SMethod -> Log
forall {f :: MessageDirection} {t :: MessageKind}.
Some SMethod -> Log
LogNoPluginForMethod (Some SMethod -> Log) -> Some SMethod -> Log
forall a b. (a -> b) -> a -> b
$ SMethod a -> Some SMethod
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
            ((PluginId, PluginDescriptor IdeState,
  IdeState -> VFS -> MessageParams a -> LspT Config IO ())
 -> LspT Config IO ())
-> NonEmpty
     (PluginId, PluginDescriptor IdeState,
      IdeState -> VFS -> MessageParams a -> LspT Config IO ())
-> LspT Config IO ()
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) -> PluginId -> ByteString -> LspT Config IO () -> LspT Config IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
PluginId -> ByteString -> m a -> m a
otTracedProvider PluginId
pid (String -> ByteString
forall a. IsString a => String -> a
fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ SMethod a -> String
forall a. Show a => a -> String
show SMethod a
m) (LspT Config IO () -> LspT Config IO ())
-> LspT Config IO () -> LspT Config IO ()
forall a b. (a -> b) -> a -> b
$ IdeState -> VFS -> MessageParams a -> LspT Config IO ()
f IdeState
ide VFS
vfs MessageParams a
params
                                    LspT Config IO ()
-> (SomeException -> LspT Config IO ()) -> LspT Config IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`catchAny` -- See Note [Exception handling in plugins]
                                    (\SomeException
e -> Recorder (WithPriority Log) -> Priority -> Log -> LspT Config IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Warning (PluginId -> Some SMethod -> SomeException -> Log
forall {f :: MessageDirection} {t :: MessageKind}.
PluginId -> Some SMethod -> SomeException -> Log
ExceptionInPlugin PluginId
pid (SMethod a -> Some SMethod
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 = NonEmpty (PluginId, a -> b -> m (NonEmpty (Either PluginError d)))
-> ((PluginId, a -> b -> m (NonEmpty (Either PluginError d)))
    -> m (NonEmpty (Either PluginError d)))
-> m (NonEmpty (NonEmpty (Either PluginError d)))
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 (((PluginId, a -> b -> m (NonEmpty (Either PluginError d)))
  -> m (NonEmpty (Either PluginError d)))
 -> m (NonEmpty (NonEmpty (Either PluginError d))))
-> ((PluginId, a -> b -> m (NonEmpty (Either PluginError d)))
    -> m (NonEmpty (Either PluginError d)))
-> m (NonEmpty (NonEmpty (Either PluginError d)))
forall a b. (a -> b) -> a -> b
$ \(PluginId
pid,a -> b -> m (NonEmpty (Either PluginError d))
f) -> PluginId
-> ByteString
-> m (NonEmpty (Either PluginError d))
-> m (NonEmpty (Either PluginError d))
forall (m :: * -> *) a.
MonadUnliftIO m =>
PluginId -> ByteString -> m a -> m a
otTracedProvider PluginId
pid (String -> ByteString
forall a. IsString a => String -> a
fromString (SMethod method -> String
forall a. Show a => a -> String
show SMethod method
method)) (m (NonEmpty (Either PluginError d))
 -> m (NonEmpty (Either PluginError d)))
-> m (NonEmpty (Either PluginError d))
-> m (NonEmpty (Either PluginError d))
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]
     m (NonEmpty (Either PluginError d))
-> (SomeException -> m (NonEmpty (Either PluginError d)))
-> m (NonEmpty (Either PluginError d))
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`catchAny` (\SomeException
e -> NonEmpty (Either PluginError d)
-> m (NonEmpty (Either PluginError d))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NonEmpty (Either PluginError d)
 -> m (NonEmpty (Either PluginError d)))
-> NonEmpty (Either PluginError d)
-> m (NonEmpty (Either PluginError d))
forall a b. (a -> b) -> a -> b
$ Either PluginError d -> NonEmpty (Either PluginError d)
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either PluginError d -> NonEmpty (Either PluginError d))
-> Either PluginError d -> NonEmpty (Either PluginError d)
forall a b. (a -> b) -> a -> b
$ PluginError -> Either PluginError d
forall a b. a -> Either a b
Left (PluginError -> Either PluginError d)
-> PluginError -> Either PluginError d
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) -> TResponseError m
combineErrors :: forall {f :: MessageDirection} (m :: Method f 'Request).
NonEmpty (PluginId, PluginError) -> TResponseError m
combineErrors ((PluginId, PluginError)
x NE.:| []) = (PluginId, PluginError) -> TResponseError m
forall {f :: MessageDirection} (m :: Method f 'Request).
(PluginId, PluginError) -> TResponseError m
toResponseError (PluginId, PluginError)
x
combineErrors NonEmpty (PluginId, PluginError)
xs = (PluginId, PluginError) -> TResponseError m
forall {f :: MessageDirection} (m :: Method f 'Request).
(PluginId, PluginError) -> TResponseError m
toResponseError ((PluginId, PluginError) -> TResponseError m)
-> (PluginId, PluginError) -> TResponseError m
forall a b. (a -> b) -> a -> b
$ NonEmpty (PluginId, PluginError) -> (PluginId, PluginError)
forall a. NonEmpty a -> a
NE.last (NonEmpty (PluginId, PluginError) -> (PluginId, PluginError))
-> NonEmpty (PluginId, PluginError) -> (PluginId, PluginError)
forall a b. (a -> b) -> a -> b
$ ((PluginId, PluginError) -> Priority)
-> NonEmpty (PluginId, PluginError)
-> NonEmpty (PluginId, PluginError)
forall o a. Ord o => (a -> o) -> NonEmpty a -> NonEmpty a
NE.sortWith (PluginError -> Priority
toPriority (PluginError -> Priority)
-> ((PluginId, PluginError) -> PluginError)
-> (PluginId, PluginError)
-> Priority
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PluginId, PluginError) -> PluginError
forall a b. (a, b) -> b
snd) NonEmpty (PluginId, PluginError)
xs

toResponseError :: (PluginId, PluginError) -> TResponseError m
toResponseError :: forall {f :: MessageDirection} (m :: Method f 'Request).
(PluginId, PluginError) -> TResponseError m
toResponseError (PluginId Text
plId, PluginError
err) =
        (LSPErrorCodes |? ErrorCodes)
-> Text -> Maybe (ErrorData m) -> TResponseError m
forall (f :: MessageDirection) (m :: Method f 'Request).
(LSPErrorCodes |? ErrorCodes)
-> Text -> Maybe (ErrorData m) -> TResponseError m
TResponseError (PluginError -> LSPErrorCodes |? ErrorCodes
toErrorCode PluginError
err) (Text
plId Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> PluginError -> Text
tPretty PluginError
err) Maybe (ErrorData m)
forall a. Maybe a
Nothing
    where tPretty :: PluginError -> Text
tPretty = String -> Text
T.pack (String -> Text) -> (PluginError -> String) -> PluginError -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc Any -> String
forall a. Show a => a -> String
show (Doc Any -> String)
-> (PluginError -> Doc Any) -> PluginError -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PluginError -> Doc Any
forall ann. PluginError -> Doc ann
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
  [(PluginId, PluginError)]
-> ((PluginId, PluginError) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(PluginId, PluginError)]
errs (((PluginId, PluginError) -> IO ()) -> IO ())
-> ((PluginId, PluginError) -> IO ()) -> IO ()
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 =
          Recorder (WithPriority Log) -> Priority -> Log -> IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder (PluginError -> Priority
toPriority PluginError
err) (Log -> IO ()) -> Log -> IO ()
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 -> HandlerM 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 (DMap IdeMethod IdeHandler -> IdeHandlers)
-> DMap IdeMethod IdeHandler -> IdeHandlers
forall a b. (a -> b) -> a -> b
$ (forall (v :: Method 'ClientToServer 'Request).
 IdeMethod v -> IdeHandler v -> IdeHandler v -> IdeHandler v)
-> DMap IdeMethod IdeHandler
-> DMap IdeMethod IdeHandler
-> DMap IdeMethod IdeHandler
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 IdeMethod v -> IdeHandler v -> IdeHandler v -> IdeHandler v
forall (v :: Method 'ClientToServer 'Request).
IdeMethod v -> IdeHandler v -> IdeHandler v -> IdeHandler v
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
  -> HandlerM
       Config (NonEmpty (Either PluginError (MessageResult m))))]
c) (IdeHandler [(PluginId, PluginDescriptor IdeState,
  IdeState
  -> MessageParams m
  -> HandlerM
       Config (NonEmpty (Either PluginError (MessageResult m))))]
d) = [(PluginId, PluginDescriptor IdeState,
  IdeState
  -> MessageParams m
  -> HandlerM
       Config (NonEmpty (Either PluginError (MessageResult m))))]
-> IdeHandler m
forall (m :: Method 'ClientToServer 'Request).
[(PluginId, PluginDescriptor IdeState,
  IdeState
  -> MessageParams m
  -> HandlerM
       Config (NonEmpty (Either PluginError (MessageResult m))))]
-> IdeHandler m
IdeHandler ([(PluginId, PluginDescriptor IdeState,
  IdeState
  -> MessageParams m
  -> HandlerM
       Config (NonEmpty (Either PluginError (MessageResult m))))]
[(PluginId, PluginDescriptor IdeState,
  IdeState
  -> MessageParams m
  -> HandlerM
       Config (NonEmpty (Either PluginError (MessageResult m))))]
c [(PluginId, PluginDescriptor IdeState,
  IdeState
  -> MessageParams m
  -> HandlerM
       Config (NonEmpty (Either PluginError (MessageResult m))))]
-> [(PluginId, PluginDescriptor IdeState,
     IdeState
     -> MessageParams m
     -> HandlerM
          Config (NonEmpty (Either PluginError (MessageResult m))))]
-> [(PluginId, PluginDescriptor IdeState,
     IdeState
     -> MessageParams m
     -> HandlerM
          Config (NonEmpty (Either PluginError (MessageResult m))))]
forall a. Semigroup a => a -> a -> a
<> [(PluginId, PluginDescriptor IdeState,
  IdeState
  -> MessageParams m
  -> HandlerM
       Config (NonEmpty (Either PluginError (MessageResult m))))]
[(PluginId, PluginDescriptor IdeState,
  IdeState
  -> MessageParams m
  -> HandlerM
       Config (NonEmpty (Either PluginError (MessageResult m))))]
d)
instance Monoid IdeHandlers where
  mempty :: IdeHandlers
mempty = DMap IdeMethod IdeHandler -> IdeHandlers
IdeHandlers DMap IdeMethod IdeHandler
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 (DMap IdeNotification IdeNotificationHandler
 -> IdeNotificationHandlers)
-> DMap IdeNotification IdeNotificationHandler
-> IdeNotificationHandlers
forall a b. (a -> b) -> a -> b
$ (forall (v :: Method 'ClientToServer 'Notification).
 IdeNotification v
 -> IdeNotificationHandler v
 -> IdeNotificationHandler v
 -> IdeNotificationHandler v)
-> DMap IdeNotification IdeNotificationHandler
-> DMap IdeNotification IdeNotificationHandler
-> DMap IdeNotification IdeNotificationHandler
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 IdeNotification v
-> IdeNotificationHandler v
-> IdeNotificationHandler v
-> IdeNotificationHandler v
forall (v :: Method 'ClientToServer 'Notification).
IdeNotification v
-> IdeNotificationHandler v
-> IdeNotificationHandler v
-> IdeNotificationHandler v
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) = [(PluginId, PluginDescriptor IdeState,
  IdeState -> VFS -> MessageParams m -> LspT Config IO ())]
-> IdeNotificationHandler m
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 ())]
[(PluginId, PluginDescriptor IdeState,
  IdeState -> VFS -> MessageParams m -> LspT Config IO ())]
c [(PluginId, PluginDescriptor IdeState,
  IdeState -> VFS -> MessageParams m -> LspT Config IO ())]
-> [(PluginId, PluginDescriptor IdeState,
     IdeState -> VFS -> MessageParams m -> LspT Config IO ())]
-> [(PluginId, PluginDescriptor IdeState,
     IdeState -> VFS -> MessageParams m -> LspT Config IO ())]
forall a. Semigroup a => a -> a -> a
<> [(PluginId, PluginDescriptor IdeState,
  IdeState -> VFS -> MessageParams m -> LspT Config IO ())]
[(PluginId, PluginDescriptor IdeState,
  IdeState -> VFS -> MessageParams m -> LspT Config IO ())]
d)
instance Monoid IdeNotificationHandlers where
  mempty :: IdeNotificationHandlers
mempty = DMap IdeNotification IdeNotificationHandler
-> IdeNotificationHandlers
IdeNotificationHandlers DMap IdeNotification IdeNotificationHandler
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!
-}