{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE GADTs #-}

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

import           Control.Exception(SomeException)
import           Control.Monad
import qualified Data.Aeson as J
import           Data.Either
import qualified Data.List                     as List
import qualified Data.Map  as Map
import qualified Data.Text                     as T
import           Development.IDE.Core.Shake
import           Development.IDE.LSP.Server
import           Development.IDE.Plugin
import           Ide.Plugin.Config
import           Ide.Types as HLS
import qualified Language.LSP.Server             as LSP
import qualified Language.LSP.Types              as J
import Language.LSP.Types
import           Text.Regex.TDFA.Text()
import Development.Shake (Rules)
import Ide.PluginUtils (getClientConfig)
import Development.IDE.Core.Tracing
import UnliftIO.Async (forConcurrently)
import UnliftIO.Exception (catchAny)
import           Data.Dependent.Map (DMap)
import qualified Data.Dependent.Map as DMap
import           Data.Dependent.Sum
import Data.List.NonEmpty (nonEmpty,NonEmpty,toList)
import UnliftIO (MonadUnliftIO)
import Data.String
import Data.Bifunctor

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

-- | Map a set of plugins to the underlying ghcide engine.
asGhcIdePlugin :: IdePlugins IdeState -> Plugin Config
asGhcIdePlugin :: IdePlugins IdeState -> Plugin Config
asGhcIdePlugin IdePlugins IdeState
mp =
    ([(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
    where
        ls :: [(PluginId, PluginDescriptor IdeState)]
ls = Map PluginId (PluginDescriptor IdeState)
-> [(PluginId, PluginDescriptor IdeState)]
forall k a. Map k a -> [(k, a)]
Map.toList (IdePlugins IdeState -> Map PluginId (PluginDescriptor IdeState)
forall ideState.
IdePlugins ideState -> Map PluginId (PluginDescriptor ideState)
ipMap IdePlugins IdeState
mp)

        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 = Rules () -> Handlers (ServerM Config) -> Plugin Config
forall c. Rules () -> Handlers (ServerM c) -> Plugin c
Plugin Rules ()
rules Handlers (ServerM Config)
forall a. Monoid a => a
mempty
    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

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

executeCommandPlugins :: [(PluginId, [PluginCommand IdeState])] -> Plugin Config
executeCommandPlugins :: [(PluginId, [PluginCommand IdeState])] -> Plugin Config
executeCommandPlugins [(PluginId, [PluginCommand IdeState])]
ecs = Rules () -> Handlers (ServerM Config) -> Plugin Config
forall c. Rules () -> Handlers (ServerM c) -> Plugin c
Plugin Rules ()
forall a. Monoid a => a
mempty ([(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 = Rules () -> Handlers (ServerM Config) -> Plugin Config
forall c. Rules () -> Handlers (ServerM c) -> Plugin c
Plugin Rules ()
forall a. Monoid a => a
mempty 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
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

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 'PluginHandlers' for all plugins
newtype IdeHandlers = IdeHandlers (DMap IdeMethod IdeHandler)

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. [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