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

module Development.IDE.Plugin.HLS
    (
      asGhcIdePlugin
    ) where

import           Control.Exception            (SomeException)
import           Control.Monad
import           Control.Monad.IO.Class
import qualified Data.Aeson                   as J
import           Data.Bifunctor
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.Map                     as Map
import           Data.String
import qualified Data.Text                    as T
import           Development.IDE.Core.Shake
import           Development.IDE.Core.Tracing
import           Development.IDE.Graph        (Rules)
import           Development.IDE.LSP.Server
import           Development.IDE.Plugin
import qualified Development.IDE.Plugin       as P
import           Development.IDE.Types.Logger
import           Ide.Plugin.Config
import           Ide.PluginUtils              (getClientConfig)
import           Ide.Types                    as HLS
import qualified Language.LSP.Server          as LSP
import           Language.LSP.Types
import qualified Language.LSP.Types           as J
import           Text.Regex.TDFA.Text         ()
import           UnliftIO                     (MonadUnliftIO)
import           UnliftIO.Async               (forConcurrently)
import           UnliftIO.Exception           (catchAny)

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

-- | Map a set of plugins to the underlying ghcide engine.
asGhcIdePlugin :: IdePlugins IdeState -> Plugin Config
asGhcIdePlugin :: IdePlugins IdeState -> Plugin Config
asGhcIdePlugin (IdePlugins [(PluginId, 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 [(PluginId, [PluginCommand IdeState])] -> Plugin Config
executeCommandPlugins 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, PluginHandlers IdeState)] -> Plugin Config)
-> (PluginDescriptor IdeState -> PluginHandlers IdeState)
-> Plugin Config
forall b.
([(PluginId, b)] -> Plugin Config)
-> (PluginDescriptor IdeState -> b) -> Plugin Config
mkPlugin [(PluginId, PluginHandlers IdeState)] -> Plugin Config
extensiblePlugins PluginDescriptor IdeState -> PluginHandlers IdeState
forall ideState.
PluginDescriptor ideState -> PluginHandlers ideState
HLS.pluginHandlers Plugin Config -> Plugin Config -> Plugin Config
forall a. Semigroup a => a -> a -> a
<>
    ([(PluginId, PluginNotificationHandlers IdeState)]
 -> Plugin Config)
-> (PluginDescriptor IdeState
    -> PluginNotificationHandlers IdeState)
-> Plugin Config
forall b.
([(PluginId, b)] -> Plugin Config)
-> (PluginDescriptor IdeState -> b) -> Plugin Config
mkPlugin [(PluginId, PluginNotificationHandlers IdeState)] -> Plugin Config
extensibleNotificationPlugins PluginDescriptor IdeState -> PluginNotificationHandlers IdeState
forall ideState.
PluginDescriptor ideState -> PluginNotificationHandlers ideState
HLS.pluginNotificationHandlers Plugin Config -> Plugin Config -> Plugin Config
forall a. Semigroup a => a -> a -> a
<>
    ([(PluginId, DynFlagsModifications)] -> Plugin Config)
-> (PluginDescriptor IdeState -> DynFlagsModifications)
-> Plugin Config
forall b.
([(PluginId, b)] -> Plugin Config)
-> (PluginDescriptor IdeState -> b) -> Plugin Config
mkPlugin [(PluginId, 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)
-> (PluginDescriptor IdeState -> b) -> Plugin Config
mkPlugin [(PluginId, b)] -> Plugin Config
maker PluginDescriptor IdeState -> b
selector =
          case ((PluginId, PluginDescriptor IdeState) -> (PluginId, b))
-> [(PluginId, PluginDescriptor IdeState)] -> [(PluginId, b)]
forall a b. (a -> b) -> [a] -> [b]
map ((PluginDescriptor IdeState -> b)
-> (PluginId, PluginDescriptor IdeState) -> (PluginId, b)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second PluginDescriptor IdeState -> b
selector) [(PluginId, 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
            [(PluginId, b)]
xs -> [(PluginId, b)] -> Plugin Config
maker [(PluginId, b)]
xs

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

rulesPlugins :: [(PluginId, Rules ())] -> Plugin Config
rulesPlugins :: [(PluginId, Rules ())] -> Plugin Config
rulesPlugins [(PluginId, Rules ())]
rs = Plugin Config
forall a. Monoid a => a
mempty { pluginRules :: Rules ()
P.pluginRules = Rules ()
rules }
    where
        rules :: Rules ()
rules = ((PluginId, Rules ()) -> Rules ())
-> [(PluginId, Rules ())] -> Rules ()
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 :: [(PluginId, DynFlagsModifications)] -> Plugin Config
dynFlagsPlugins :: [(PluginId, DynFlagsModifications)] -> Plugin Config
dynFlagsPlugins [(PluginId, DynFlagsModifications)]
rs = Plugin Config
forall a. Monoid a => a
mempty
  { pluginModifyDynflags :: Config -> DynFlagsModifications
P.pluginModifyDynflags =
      (((PluginId, DynFlagsModifications)
  -> Config -> DynFlagsModifications)
 -> [(PluginId, DynFlagsModifications)]
 -> Config
 -> DynFlagsModifications)
-> [(PluginId, DynFlagsModifications)]
-> ((PluginId, DynFlagsModifications)
    -> Config -> DynFlagsModifications)
-> Config
-> DynFlagsModifications
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((PluginId, DynFlagsModifications)
 -> Config -> DynFlagsModifications)
-> [(PluginId, DynFlagsModifications)]
-> Config
-> DynFlagsModifications
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap [(PluginId, DynFlagsModifications)]
rs (((PluginId, DynFlagsModifications)
  -> Config -> DynFlagsModifications)
 -> Config -> DynFlagsModifications)
-> ((PluginId, DynFlagsModifications)
    -> Config -> DynFlagsModifications)
-> Config
-> DynFlagsModifications
forall a b. (a -> b) -> a -> b
$ \(PluginId
plId, DynFlagsModifications
dflag_mods) Config
cfg ->
        let plg_cfg :: PluginConfig
plg_cfg = Config -> PluginId -> PluginConfig
configForPlugin Config
cfg PluginId
plId
         in if PluginConfig -> Bool
plcGlobalOn PluginConfig
plg_cfg
              then DynFlagsModifications
dflag_mods
              else DynFlagsModifications
forall a. Monoid a => a
mempty
  }

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

executeCommandPlugins :: [(PluginId, [PluginCommand IdeState])] -> Plugin Config
executeCommandPlugins :: [(PluginId, [PluginCommand IdeState])] -> Plugin Config
executeCommandPlugins [(PluginId, [PluginCommand IdeState])]
ecs = Plugin Config
forall a. Monoid a => a
mempty { pluginHandlers :: Handlers (ServerM Config)
P.pluginHandlers = [(PluginId, [PluginCommand IdeState])] -> Handlers (ServerM Config)
executeCommandHandlers [(PluginId, [PluginCommand IdeState])]
ecs }

executeCommandHandlers :: [(PluginId, [PluginCommand IdeState])] -> LSP.Handlers (ServerM Config)
executeCommandHandlers :: [(PluginId, [PluginCommand IdeState])] -> Handlers (ServerM Config)
executeCommandHandlers [(PluginId, [PluginCommand IdeState])]
ecs = SMethod 'WorkspaceExecuteCommand
-> (IdeState
    -> MessageParams 'WorkspaceExecuteCommand
    -> LspM
         Config
         (Either ResponseError (ResponseResult 'WorkspaceExecuteCommand)))
-> Handlers (ServerM Config)
forall (m :: Method 'FromClient 'Request) c.
HasTracing (MessageParams m) =>
SMethod m
-> (IdeState
    -> MessageParams m
    -> LspM c (Either ResponseError (ResponseResult m)))
-> Handlers (ServerM c)
requestHandler SMethod 'WorkspaceExecuteCommand
SWorkspaceExecuteCommand IdeState
-> MessageParams 'WorkspaceExecuteCommand
-> LspM
     Config
     (Either ResponseError (ResponseResult 'WorkspaceExecuteCommand))
IdeState
-> ExecuteCommandParams
-> LspT Config IO (Either ResponseError Value)
execCmd
  where
    pluginMap :: Map PluginId [PluginCommand IdeState]
pluginMap = [(PluginId, [PluginCommand IdeState])]
-> Map PluginId [PluginCommand IdeState]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(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]    -> (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
-> LspT Config IO (Either ResponseError Value)
execCmd IdeState
ide (ExecuteCommandParams Maybe ProgressToken
_ Text
cmdId Maybe (List Value)
args) = do
      let cmdParams :: J.Value
          cmdParams :: Value
cmdParams = case Maybe (List Value)
args of
            Just (J.List (Value
x:[Value]
_)) -> Value
x
            Maybe (List Value)
_                   -> Value
J.Null
      case Text -> Maybe (PluginId, CommandId)
parseCmdId Text
cmdId of
        -- 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
J.fromJSON Value
cmdParams of
            J.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 '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 'WorkspaceApplyEdit))
 -> LspT Config IO ())
-> (WorkspaceEdit -> LspT Config IO (LspId 'WorkspaceApplyEdit))
-> LspT Config IO ()
forall a b. (a -> b) -> a -> b
$ \WorkspaceEdit
edit ->
                SServerMethod 'WorkspaceApplyEdit
-> MessageParams 'WorkspaceApplyEdit
-> (Either ResponseError (ResponseResult 'WorkspaceApplyEdit)
    -> LspT Config IO ())
-> LspT Config IO (LspId 'WorkspaceApplyEdit)
forall (m :: Method 'FromServer 'Request) (f :: * -> *) config.
MonadLsp config f =>
SServerMethod m
-> MessageParams m
-> (Either ResponseError (ResponseResult m) -> f ())
-> f (LspId m)
LSP.sendRequest SServerMethod 'WorkspaceApplyEdit
SWorkspaceApplyEdit (Maybe Text -> WorkspaceEdit -> ApplyWorkspaceEditParams
ApplyWorkspaceEditParams Maybe Text
forall a. Maybe a
Nothing WorkspaceEdit
edit) (\Either ResponseError (ResponseResult 'WorkspaceApplyEdit)
_ -> () -> LspT Config IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

              case Maybe Command
mCmd of
                -- If we have a command, continue to execute it
                Just (J.Command Text
_ Text
innerCmdId Maybe (List Value)
innerArgs)
                    -> IdeState
-> ExecuteCommandParams
-> LspT Config IO (Either ResponseError Value)
execCmd IdeState
ide (Maybe ProgressToken
-> Text -> Maybe (List Value) -> ExecuteCommandParams
ExecuteCommandParams Maybe ProgressToken
forall a. Maybe a
Nothing Text
innerCmdId Maybe (List Value)
innerArgs)
                Maybe Command
Nothing -> Either ResponseError Value
-> LspT Config IO (Either ResponseError Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ResponseError Value
 -> LspT Config IO (Either ResponseError Value))
-> Either ResponseError Value
-> LspT Config IO (Either ResponseError Value)
forall a b. (a -> b) -> a -> b
$ Value -> Either ResponseError Value
forall a b. b -> Either a b
Right Value
J.Null

            J.Error String
_str -> Either ResponseError Value
-> LspT Config IO (Either ResponseError Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ResponseError Value
 -> LspT Config IO (Either ResponseError Value))
-> Either ResponseError Value
-> LspT Config IO (Either ResponseError Value)
forall a b. (a -> b) -> a -> b
$ Value -> Either ResponseError Value
forall a b. b -> Either a b
Right Value
J.Null

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

        -- Couldn't parse the command identifier
        Maybe (PluginId, CommandId)
_ -> Either ResponseError Value
-> LspT Config IO (Either ResponseError Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ResponseError Value
 -> LspT Config IO (Either ResponseError Value))
-> Either ResponseError Value
-> LspT Config IO (Either ResponseError Value)
forall a b. (a -> b) -> a -> b
$ ResponseError -> Either ResponseError Value
forall a b. a -> Either a b
Left (ResponseError -> Either ResponseError Value)
-> ResponseError -> Either ResponseError Value
forall a b. (a -> b) -> a -> b
$ ErrorCode -> Text -> Maybe Value -> ResponseError
ResponseError ErrorCode
InvalidParams Text
"Invalid command identifier" Maybe Value
forall a. Maybe a
Nothing

    runPluginCommand :: IdeState
-> PluginId
-> CommandId
-> Value
-> LspT Config IO (Either ResponseError Value)
runPluginCommand IdeState
ide p :: PluginId
p@(PluginId Text
p') com :: CommandId
com@(CommandId Text
com') 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 -> Either ResponseError Value
-> LspT Config IO (Either ResponseError Value)
forall (m :: * -> *) a. Monad m => a -> m a
return
          (ResponseError -> Either ResponseError Value
forall a b. a -> Either a b
Left (ResponseError -> Either ResponseError Value)
-> ResponseError -> Either ResponseError Value
forall a b. (a -> b) -> a -> b
$ ErrorCode -> Text -> Maybe Value -> ResponseError
ResponseError ErrorCode
InvalidRequest (Text
"Plugin " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
p' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" doesn't exist") Maybe Value
forall a. Maybe a
Nothing)
        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 -> CommandId -> Bool
forall a. Eq a => a -> a -> Bool
==) (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 -> Either ResponseError Value
-> LspT Config IO (Either ResponseError Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ResponseError Value
 -> LspT Config IO (Either ResponseError Value))
-> Either ResponseError Value
-> LspT Config IO (Either ResponseError Value)
forall a b. (a -> b) -> a -> b
$ ResponseError -> Either ResponseError Value
forall a b. a -> Either a b
Left (ResponseError -> Either ResponseError Value)
-> ResponseError -> Either ResponseError Value
forall a b. (a -> b) -> a -> b
$
            ErrorCode -> Text -> Maybe Value -> ResponseError
ResponseError ErrorCode
InvalidRequest (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
p'
                                          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
". Legal commands are: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack([CommandId] -> String
forall a. Show a => a -> String
show ([CommandId] -> String) -> [CommandId] -> String
forall a b. (a -> b) -> a -> b
$ (PluginCommand IdeState -> CommandId)
-> [PluginCommand IdeState] -> [CommandId]
forall a b. (a -> b) -> [a] -> [b]
map PluginCommand IdeState -> CommandId
forall ideState. PluginCommand ideState -> CommandId
commandId [PluginCommand IdeState]
xs)) Maybe Value
forall a. Maybe a
Nothing
          Just (PluginCommand CommandId
_ Text
_ CommandFunction IdeState a
f) -> case Value -> Result a
forall a. FromJSON a => Value -> Result a
J.fromJSON Value
arg of
            J.Error String
err -> Either ResponseError Value
-> LspT Config IO (Either ResponseError Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ResponseError Value
 -> LspT Config IO (Either ResponseError Value))
-> Either ResponseError Value
-> LspT Config IO (Either ResponseError Value)
forall a b. (a -> b) -> a -> b
$ ResponseError -> Either ResponseError Value
forall a b. a -> Either a b
Left (ResponseError -> Either ResponseError Value)
-> ResponseError -> Either ResponseError Value
forall a b. (a -> b) -> a -> b
$
              ErrorCode -> Text -> Maybe Value -> ResponseError
ResponseError ErrorCode
InvalidParams (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
p'
                                           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
"\narg = " 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)) Maybe Value
forall a. Maybe a
Nothing
            J.Success a
a -> CommandFunction IdeState a
f IdeState
ide a
a

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

extensiblePlugins :: [(PluginId, PluginHandlers IdeState)] -> Plugin Config
extensiblePlugins :: [(PluginId, PluginHandlers IdeState)] -> Plugin Config
extensiblePlugins [(PluginId, PluginHandlers IdeState)]
xs = Plugin Config
forall a. Monoid a => a
mempty { pluginHandlers :: Handlers (ServerM Config)
P.pluginHandlers = Handlers (ServerM Config)
handlers }
  where
    IdeHandlers DMap IdeMethod IdeHandler
handlers' = ((PluginId, PluginHandlers IdeState) -> IdeHandlers)
-> [(PluginId, PluginHandlers IdeState)] -> IdeHandlers
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (PluginId, PluginHandlers IdeState) -> IdeHandlers
bakePluginId [(PluginId, PluginHandlers IdeState)]
xs
    bakePluginId :: (PluginId, PluginHandlers IdeState) -> IdeHandlers
    bakePluginId :: (PluginId, PluginHandlers IdeState) -> IdeHandlers
bakePluginId (PluginId
pid,PluginHandlers DMap IdeMethod (PluginHandler IdeState)
hs) = DMap IdeMethod IdeHandler -> IdeHandlers
IdeHandlers (DMap IdeMethod IdeHandler -> IdeHandlers)
-> DMap IdeMethod IdeHandler -> IdeHandlers
forall a b. (a -> b) -> a -> b
$ (forall (v :: Method 'FromClient '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 f) -> [(PluginId,
  IdeState
  -> MessageParams v
  -> LspM
       Config (NonEmpty (Either ResponseError (ResponseResult v))))]
-> IdeHandler v
forall (m :: Method 'FromClient 'Request).
[(PluginId,
  IdeState
  -> MessageParams m
  -> LspM
       Config (NonEmpty (Either ResponseError (ResponseResult m))))]
-> IdeHandler m
IdeHandler [(PluginId
pid,PluginId
-> IdeState
-> MessageParams v
-> LspM Config (NonEmpty (Either ResponseError (ResponseResult v)))
f PluginId
pid)])
      DMap IdeMethod (PluginHandler IdeState)
hs
    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,
  IdeState
  -> MessageParams a
  -> LspM
       Config (NonEmpty (Either ResponseError (ResponseResult 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 (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 ResponseError (ResponseResult a)))
-> Handlers (ServerM Config)
forall (m :: Method 'FromClient 'Request) c.
HasTracing (MessageParams m) =>
SMethod m
-> (IdeState
    -> MessageParams m
    -> LspM c (Either ResponseError (ResponseResult m)))
-> Handlers (ServerM c)
requestHandler SMethod a
m ((IdeState
  -> MessageParams a
  -> LspM Config (Either ResponseError (ResponseResult a)))
 -> Handlers (ServerM Config))
-> (IdeState
    -> MessageParams a
    -> LspM Config (Either ResponseError (ResponseResult 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
        let fs :: [(PluginId,
  IdeState
  -> MessageParams a
  -> LspM
       Config (NonEmpty (Either ResponseError (ResponseResult a))))]
fs = ((PluginId,
  IdeState
  -> MessageParams a
  -> LspM
       Config (NonEmpty (Either ResponseError (ResponseResult a))))
 -> Bool)
-> [(PluginId,
     IdeState
     -> MessageParams a
     -> LspM
          Config (NonEmpty (Either ResponseError (ResponseResult a))))]
-> [(PluginId,
     IdeState
     -> MessageParams a
     -> LspM
          Config (NonEmpty (Either ResponseError (ResponseResult a))))]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(PluginId
pid,IdeState
-> MessageParams a
-> LspM Config (NonEmpty (Either ResponseError (ResponseResult a)))
_) -> SMethod a -> PluginId -> Config -> Bool
forall (f :: From) (m :: Method f 'Request).
PluginMethod m =>
SMethod m -> PluginId -> Config -> Bool
pluginEnabled SMethod a
m PluginId
pid Config
config) [(PluginId,
  IdeState
  -> MessageParams a
  -> LspM
       Config (NonEmpty (Either ResponseError (ResponseResult a))))]
fs'
        case [(PluginId,
  IdeState
  -> MessageParams a
  -> LspM
       Config (NonEmpty (Either ResponseError (ResponseResult a))))]
-> Maybe
     (NonEmpty
        (PluginId,
         IdeState
         -> MessageParams a
         -> LspM
              Config (NonEmpty (Either ResponseError (ResponseResult a)))))
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [(PluginId,
  IdeState
  -> MessageParams a
  -> LspM
       Config (NonEmpty (Either ResponseError (ResponseResult a))))]
fs of
          Maybe
  (NonEmpty
     (PluginId,
      IdeState
      -> MessageParams a
      -> LspM
           Config (NonEmpty (Either ResponseError (ResponseResult a)))))
Nothing -> Either ResponseError (ResponseResult a)
-> LspM Config (Either ResponseError (ResponseResult a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ResponseError (ResponseResult a)
 -> LspM Config (Either ResponseError (ResponseResult a)))
-> Either ResponseError (ResponseResult a)
-> LspM Config (Either ResponseError (ResponseResult a))
forall a b. (a -> b) -> a -> b
$ ResponseError -> Either ResponseError (ResponseResult a)
forall a b. a -> Either a b
Left (ResponseError -> Either ResponseError (ResponseResult a))
-> ResponseError -> Either ResponseError (ResponseResult a)
forall a b. (a -> b) -> a -> b
$ ErrorCode -> Text -> Maybe Value -> ResponseError
ResponseError ErrorCode
InvalidRequest
            (Text
"No plugin enabled for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (SMethod a -> String
forall a. Show a => a -> String
show SMethod a
m) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", available: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack ([PluginId] -> String
forall a. Show a => a -> String
show ([PluginId] -> String) -> [PluginId] -> String
forall a b. (a -> b) -> a -> b
$ ((PluginId,
  IdeState
  -> MessageParams a
  -> LspM
       Config (NonEmpty (Either ResponseError (ResponseResult a))))
 -> PluginId)
-> [(PluginId,
     IdeState
     -> MessageParams a
     -> LspM
          Config (NonEmpty (Either ResponseError (ResponseResult a))))]
-> [PluginId]
forall a b. (a -> b) -> [a] -> [b]
map (PluginId,
 IdeState
 -> MessageParams a
 -> LspM
      Config (NonEmpty (Either ResponseError (ResponseResult a))))
-> PluginId
forall a b. (a, b) -> a
fst [(PluginId,
  IdeState
  -> MessageParams a
  -> LspM
       Config (NonEmpty (Either ResponseError (ResponseResult a))))]
fs))
            Maybe Value
forall a. Maybe a
Nothing
          Just NonEmpty
  (PluginId,
   IdeState
   -> MessageParams a
   -> LspM
        Config (NonEmpty (Either ResponseError (ResponseResult a))))
fs -> do
            let msg :: SomeException -> PluginId -> Text
msg SomeException
e PluginId
pid = Text
"Exception in plugin " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (PluginId -> String
forall a. Show a => a -> String
show PluginId
pid) 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 a -> String
forall a. Show a => a -> String
show SMethod a
m) 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
e)
            NonEmpty (Either ResponseError (ResponseResult a))
es <- (SomeException -> PluginId -> Text)
-> String
-> NonEmpty
     (PluginId,
      IdeState
      -> MessageParams a
      -> LspM
           Config (NonEmpty (Either ResponseError (ResponseResult a))))
-> IdeState
-> MessageParams a
-> LspM Config (NonEmpty (Either ResponseError (ResponseResult a)))
forall (m :: * -> *) a b d.
MonadUnliftIO m =>
(SomeException -> PluginId -> Text)
-> String
-> NonEmpty
     (PluginId, a -> b -> m (NonEmpty (Either ResponseError d)))
-> a
-> b
-> m (NonEmpty (Either ResponseError d))
runConcurrently SomeException -> PluginId -> Text
msg (SMethod a -> String
forall a. Show a => a -> String
show SMethod a
m) NonEmpty
  (PluginId,
   IdeState
   -> MessageParams a
   -> LspM
        Config (NonEmpty (Either ResponseError (ResponseResult a))))
fs IdeState
ide MessageParams a
params
            let ([ResponseError]
errs,[ResponseResult a]
succs) = [Either ResponseError (ResponseResult a)]
-> ([ResponseError], [ResponseResult a])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either ResponseError (ResponseResult a)]
 -> ([ResponseError], [ResponseResult a]))
-> [Either ResponseError (ResponseResult a)]
-> ([ResponseError], [ResponseResult a])
forall a b. (a -> b) -> a -> b
$ NonEmpty (Either ResponseError (ResponseResult a))
-> [Either ResponseError (ResponseResult a)]
forall a. NonEmpty a -> [a]
toList NonEmpty (Either ResponseError (ResponseResult a))
es
            case [ResponseResult a] -> Maybe (NonEmpty (ResponseResult a))
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [ResponseResult a]
succs of
              Maybe (NonEmpty (ResponseResult a))
Nothing -> Either ResponseError (ResponseResult a)
-> LspM Config (Either ResponseError (ResponseResult a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ResponseError (ResponseResult a)
 -> LspM Config (Either ResponseError (ResponseResult a)))
-> Either ResponseError (ResponseResult a)
-> LspM Config (Either ResponseError (ResponseResult a))
forall a b. (a -> b) -> a -> b
$ ResponseError -> Either ResponseError (ResponseResult a)
forall a b. a -> Either a b
Left (ResponseError -> Either ResponseError (ResponseResult a))
-> ResponseError -> Either ResponseError (ResponseResult a)
forall a b. (a -> b) -> a -> b
$ [ResponseError] -> ResponseError
combineErrors [ResponseError]
errs
              Just NonEmpty (ResponseResult a)
xs -> do
                ClientCapabilities
caps <- LspT Config IO ClientCapabilities
forall config (m :: * -> *).
MonadLsp config m =>
m ClientCapabilities
LSP.getClientCapabilities
                Either ResponseError (ResponseResult a)
-> LspM Config (Either ResponseError (ResponseResult a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ResponseError (ResponseResult a)
 -> LspM Config (Either ResponseError (ResponseResult a)))
-> Either ResponseError (ResponseResult a)
-> LspM Config (Either ResponseError (ResponseResult a))
forall a b. (a -> b) -> a -> b
$ ResponseResult a -> Either ResponseError (ResponseResult a)
forall a b. b -> Either a b
Right (ResponseResult a -> Either ResponseError (ResponseResult a))
-> ResponseResult a -> Either ResponseError (ResponseResult a)
forall a b. (a -> b) -> a -> b
$ SMethod a
-> Config
-> ClientCapabilities
-> MessageParams a
-> NonEmpty (ResponseResult a)
-> ResponseResult a
forall (f :: From) (m :: Method f 'Request).
PluginMethod m =>
SMethod m
-> Config
-> ClientCapabilities
-> MessageParams m
-> NonEmpty (ResponseResult m)
-> ResponseResult m
combineResponses SMethod a
m Config
config ClientCapabilities
caps MessageParams a
params NonEmpty (ResponseResult a)
xs
-- ---------------------------------------------------------------------

extensibleNotificationPlugins :: [(PluginId, PluginNotificationHandlers IdeState)] -> Plugin Config
extensibleNotificationPlugins :: [(PluginId, PluginNotificationHandlers IdeState)] -> Plugin Config
extensibleNotificationPlugins [(PluginId, PluginNotificationHandlers IdeState)]
xs = Plugin Config
forall a. Monoid a => a
mempty { pluginHandlers :: Handlers (ServerM Config)
P.pluginHandlers = Handlers (ServerM Config)
handlers }
  where
    IdeNotificationHandlers DMap IdeNotification IdeNotificationHandler
handlers' = ((PluginId, PluginNotificationHandlers IdeState)
 -> IdeNotificationHandlers)
-> [(PluginId, PluginNotificationHandlers IdeState)]
-> IdeNotificationHandlers
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (PluginId, PluginNotificationHandlers IdeState)
-> IdeNotificationHandlers
bakePluginId [(PluginId, PluginNotificationHandlers IdeState)]
xs
    bakePluginId :: (PluginId, PluginNotificationHandlers IdeState) -> IdeNotificationHandlers
    bakePluginId :: (PluginId, PluginNotificationHandlers IdeState)
-> IdeNotificationHandlers
bakePluginId (PluginId
pid,PluginNotificationHandlers DMap IdeNotification (PluginNotificationHandler IdeState)
hs) = DMap IdeNotification IdeNotificationHandler
-> IdeNotificationHandlers
IdeNotificationHandlers (DMap IdeNotification IdeNotificationHandler
 -> IdeNotificationHandlers)
-> DMap IdeNotification IdeNotificationHandler
-> IdeNotificationHandlers
forall a b. (a -> b) -> a -> b
$ (forall (v :: Method 'FromClient '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 f) -> [(PluginId, IdeState -> MessageParams v -> LspT Config IO ())]
-> IdeNotificationHandler v
forall (m :: Method 'FromClient 'Notification).
[(PluginId, IdeState -> MessageParams m -> LspT Config IO ())]
-> IdeNotificationHandler m
IdeNotificationHandler [(PluginId
pid,PluginId -> IdeState -> MessageParams v -> LspT Config IO ()
f PluginId
pid)])
      DMap IdeNotification (PluginNotificationHandler IdeState)
hs
    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, IdeState -> 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 (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 -> LspT Config IO ())
-> Handlers (ServerM Config)
forall (m :: Method 'FromClient 'Notification) c.
HasTracing (MessageParams m) =>
SMethod m
-> (IdeState -> MessageParams m -> LspM c ())
-> Handlers (ServerM c)
notificationHandler SMethod a
m ((IdeState -> MessageParams a -> LspT Config IO ())
 -> Handlers (ServerM Config))
-> (IdeState -> MessageParams a -> LspT Config IO ())
-> 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
        let fs :: [(PluginId, IdeState -> MessageParams a -> LspT Config IO ())]
fs = ((PluginId, IdeState -> MessageParams a -> LspT Config IO ())
 -> Bool)
-> [(PluginId, IdeState -> MessageParams a -> LspT Config IO ())]
-> [(PluginId, IdeState -> MessageParams a -> LspT Config IO ())]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(PluginId
pid,IdeState -> MessageParams a -> LspT Config IO ()
_) -> PluginConfig -> Bool
plcGlobalOn (PluginConfig -> Bool) -> PluginConfig -> Bool
forall a b. (a -> b) -> a -> b
$ Config -> PluginId -> PluginConfig
configForPlugin Config
config PluginId
pid) [(PluginId, IdeState -> MessageParams a -> LspT Config IO ())]
fs'
        case [(PluginId, IdeState -> MessageParams a -> LspT Config IO ())]
-> Maybe
     (NonEmpty
        (PluginId, IdeState -> MessageParams a -> LspT Config IO ()))
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [(PluginId, IdeState -> MessageParams a -> LspT Config IO ())]
fs of
          Maybe
  (NonEmpty
     (PluginId, IdeState -> MessageParams a -> LspT Config IO ()))
Nothing -> do
              IO () -> LspT Config IO ()
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
$ Logger -> Text -> IO ()
logInfo (IdeState -> Logger
ideLogger IdeState
ide) Text
"extensibleNotificationPlugins no enabled plugins"
              () -> LspT Config IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          Just NonEmpty
  (PluginId, IdeState -> MessageParams a -> LspT Config IO ())
fs -> do
            -- We run the notifications in order, so the core ghcide provider
            -- (which restarts the shake process) hopefully comes last
              ((PluginId, IdeState -> MessageParams a -> LspT Config IO ())
 -> LspT Config IO ())
-> NonEmpty
     (PluginId, IdeState -> 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,IdeState -> 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 -> MessageParams a -> LspT Config IO ()
f IdeState
ide MessageParams a
params) NonEmpty
  (PluginId, IdeState -> MessageParams a -> LspT Config IO ())
fs

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

runConcurrently
  :: MonadUnliftIO m
  => (SomeException -> PluginId -> T.Text)
  -> String -- ^ label
  -> NonEmpty (PluginId, a -> b -> m (NonEmpty (Either ResponseError d)))
  -> a
  -> b
  -> m (NonEmpty (Either ResponseError d))
runConcurrently :: (SomeException -> PluginId -> Text)
-> String
-> NonEmpty
     (PluginId, a -> b -> m (NonEmpty (Either ResponseError d)))
-> a
-> b
-> m (NonEmpty (Either ResponseError d))
runConcurrently SomeException -> PluginId -> Text
msg String
method NonEmpty
  (PluginId, a -> b -> m (NonEmpty (Either ResponseError d)))
fs a
a b
b = (NonEmpty (NonEmpty (Either ResponseError d))
 -> NonEmpty (Either ResponseError d))
-> m (NonEmpty (NonEmpty (Either ResponseError d)))
-> m (NonEmpty (Either ResponseError d))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NonEmpty (NonEmpty (Either ResponseError d))
-> NonEmpty (Either ResponseError d)
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (m (NonEmpty (NonEmpty (Either ResponseError d)))
 -> m (NonEmpty (Either ResponseError d)))
-> m (NonEmpty (NonEmpty (Either ResponseError d)))
-> m (NonEmpty (Either ResponseError d))
forall a b. (a -> b) -> a -> b
$ NonEmpty
  (PluginId, a -> b -> m (NonEmpty (Either ResponseError d)))
-> ((PluginId, a -> b -> m (NonEmpty (Either ResponseError d)))
    -> m (NonEmpty (Either ResponseError d)))
-> m (NonEmpty (NonEmpty (Either ResponseError 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 ResponseError d)))
fs (((PluginId, a -> b -> m (NonEmpty (Either ResponseError d)))
  -> m (NonEmpty (Either ResponseError d)))
 -> m (NonEmpty (NonEmpty (Either ResponseError d))))
-> ((PluginId, a -> b -> m (NonEmpty (Either ResponseError d)))
    -> m (NonEmpty (Either ResponseError d)))
-> m (NonEmpty (NonEmpty (Either ResponseError d)))
forall a b. (a -> b) -> a -> b
$ \(PluginId
pid,a -> b -> m (NonEmpty (Either ResponseError d))
f) -> PluginId
-> ByteString
-> m (NonEmpty (Either ResponseError d))
-> m (NonEmpty (Either ResponseError d))
forall (m :: * -> *) a.
MonadUnliftIO m =>
PluginId -> ByteString -> m a -> m a
otTracedProvider PluginId
pid (String -> ByteString
forall a. IsString a => String -> a
fromString String
method) (m (NonEmpty (Either ResponseError d))
 -> m (NonEmpty (Either ResponseError d)))
-> m (NonEmpty (Either ResponseError d))
-> m (NonEmpty (Either ResponseError d))
forall a b. (a -> b) -> a -> b
$ do
  a -> b -> m (NonEmpty (Either ResponseError d))
f a
a b
b
    m (NonEmpty (Either ResponseError d))
-> (SomeException -> m (NonEmpty (Either ResponseError d)))
-> m (NonEmpty (Either ResponseError d))
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`catchAny` (\SomeException
e -> NonEmpty (Either ResponseError d)
-> m (NonEmpty (Either ResponseError d))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NonEmpty (Either ResponseError d)
 -> m (NonEmpty (Either ResponseError d)))
-> NonEmpty (Either ResponseError d)
-> m (NonEmpty (Either ResponseError d))
forall a b. (a -> b) -> a -> b
$ Either ResponseError d -> NonEmpty (Either ResponseError d)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ResponseError d -> NonEmpty (Either ResponseError d))
-> Either ResponseError d -> NonEmpty (Either ResponseError d)
forall a b. (a -> b) -> a -> b
$ ResponseError -> Either ResponseError d
forall a b. a -> Either a b
Left (ResponseError -> Either ResponseError d)
-> ResponseError -> Either ResponseError d
forall a b. (a -> b) -> a -> b
$ ErrorCode -> Text -> Maybe Value -> ResponseError
ResponseError ErrorCode
InternalError (SomeException -> PluginId -> Text
msg SomeException
e PluginId
pid) Maybe Value
forall a. Maybe a
Nothing)

combineErrors :: [ResponseError] -> ResponseError
combineErrors :: [ResponseError] -> ResponseError
combineErrors [ResponseError
x] = ResponseError
x
combineErrors [ResponseError]
xs  = ErrorCode -> Text -> Maybe Value -> ResponseError
ResponseError ErrorCode
InternalError (String -> Text
T.pack ([ResponseError] -> String
forall a. Show a => a -> String
show [ResponseError]
xs)) Maybe Value
forall a. Maybe a
Nothing

-- | Combine the 'PluginHandler' for all plugins
newtype IdeHandler (m :: J.Method FromClient Request)
  = IdeHandler [(PluginId,IdeState -> MessageParams m -> LSP.LspM Config (NonEmpty (Either ResponseError (ResponseResult m))))]

-- | Combine the 'PluginHandler' for all plugins
newtype IdeNotificationHandler (m :: J.Method FromClient Notification)
  = IdeNotificationHandler [(PluginId, IdeState -> MessageParams m -> LSP.LspM Config ())]
-- type NotificationHandler (m :: Method FromClient 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 'FromClient '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 forall (v :: Method 'FromClient 'Request).
IdeMethod v -> IdeHandler v -> IdeHandler v -> IdeHandler v
forall (m :: Method 'FromClient 'Request)
       (m :: Method 'FromClient 'Request)
       (m :: Method 'FromClient 'Request) p.
(MessageParams m ~ MessageParams m,
 MessageParams m ~ MessageParams m,
 ResponseResult m ~ ResponseResult m,
 ResponseResult m ~ ResponseResult 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,
  IdeState
  -> MessageParams m
  -> LspM
       Config (NonEmpty (Either ResponseError (ResponseResult m))))]
a) (IdeHandler [(PluginId,
  IdeState
  -> MessageParams m
  -> LspM
       Config (NonEmpty (Either ResponseError (ResponseResult m))))]
b) = [(PluginId,
  IdeState
  -> MessageParams m
  -> LspM
       Config (NonEmpty (Either ResponseError (ResponseResult m))))]
-> IdeHandler m
forall (m :: Method 'FromClient 'Request).
[(PluginId,
  IdeState
  -> MessageParams m
  -> LspM
       Config (NonEmpty (Either ResponseError (ResponseResult m))))]
-> IdeHandler m
IdeHandler ([(PluginId,
  IdeState
  -> MessageParams m
  -> LspM
       Config (NonEmpty (Either ResponseError (ResponseResult m))))]
a [(PluginId,
  IdeState
  -> MessageParams m
  -> LspM
       Config (NonEmpty (Either ResponseError (ResponseResult m))))]
-> [(PluginId,
     IdeState
     -> MessageParams m
     -> LspM
          Config (NonEmpty (Either ResponseError (ResponseResult m))))]
-> [(PluginId,
     IdeState
     -> MessageParams m
     -> LspM
          Config (NonEmpty (Either ResponseError (ResponseResult m))))]
forall a. Semigroup a => a -> a -> a
<> [(PluginId,
  IdeState
  -> MessageParams m
  -> LspM
       Config (NonEmpty (Either ResponseError (ResponseResult m))))]
[(PluginId,
  IdeState
  -> MessageParams m
  -> LspM
       Config (NonEmpty (Either ResponseError (ResponseResult m))))]
b)
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 'FromClient '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 forall (v :: Method 'FromClient 'Notification).
IdeNotification v
-> IdeNotificationHandler v
-> IdeNotificationHandler v
-> IdeNotificationHandler v
forall (m :: Method 'FromClient 'Notification)
       (m :: Method 'FromClient 'Notification)
       (m :: Method 'FromClient 'Notification) p.
(MessageParams m ~ MessageParams m,
 MessageParams m ~ MessageParams m) =>
p
-> IdeNotificationHandler m
-> IdeNotificationHandler m
-> IdeNotificationHandler m
go DMap IdeNotification IdeNotificationHandler
a DMap IdeNotification IdeNotificationHandler
b
    where
      go :: p
-> IdeNotificationHandler m
-> IdeNotificationHandler m
-> IdeNotificationHandler m
go p
_ (IdeNotificationHandler [(PluginId, IdeState -> MessageParams m -> LspT Config IO ())]
a) (IdeNotificationHandler [(PluginId, IdeState -> MessageParams m -> LspT Config IO ())]
b) = [(PluginId, IdeState -> MessageParams m -> LspT Config IO ())]
-> IdeNotificationHandler m
forall (m :: Method 'FromClient 'Notification).
[(PluginId, IdeState -> MessageParams m -> LspT Config IO ())]
-> IdeNotificationHandler m
IdeNotificationHandler ([(PluginId, IdeState -> MessageParams m -> LspT Config IO ())]
a [(PluginId, IdeState -> MessageParams m -> LspT Config IO ())]
-> [(PluginId, IdeState -> MessageParams m -> LspT Config IO ())]
-> [(PluginId, IdeState -> MessageParams m -> LspT Config IO ())]
forall a. Semigroup a => a -> a -> a
<> [(PluginId, IdeState -> MessageParams m -> LspT Config IO ())]
[(PluginId, IdeState -> MessageParams m -> LspT Config IO ())]
b)
instance Monoid IdeNotificationHandlers where
  mempty :: IdeNotificationHandlers
mempty = DMap IdeNotification IdeNotificationHandler
-> IdeNotificationHandlers
IdeNotificationHandlers DMap IdeNotification IdeNotificationHandler
forall a. Monoid a => a
mempty