{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE DeriveAnyClass    #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE DeriveGeneric     #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Ide.Plugin
    (
      asGhcIdePlugin
    , pluginDescToIdePlugins
    , mkLspCommand
    , mkLspCmdId
    , allLspCmdIds
    , allLspCmdIds'
    , getPid
    , responseError
    , getClientConfig
    , getClientConfigAction
    ) where

import           Control.Exception(SomeException, catch)
import           Control.Lens ( (^.) )
import           Control.Monad
import qualified Data.Aeson as J
import qualified Data.Default
import           Data.Either
import           Data.Hashable (unhashed)
import qualified Data.List                     as List
import qualified Data.Map  as Map
import           Data.Maybe
import qualified Data.Text                     as T
import           Development.IDE   hiding (pluginRules)
import           Development.IDE.LSP.Server
import           GHC.Generics
import           Ide.Logger
import           Ide.Plugin.Config
import           Ide.Plugin.Formatter
import           Ide.Types
import qualified Language.Haskell.LSP.Core as LSP
import           Language.Haskell.LSP.Messages
import           Language.Haskell.LSP.Types
import qualified Language.Haskell.LSP.Types              as J
import qualified Language.Haskell.LSP.Types.Capabilities as C
import           Language.Haskell.LSP.Types.Lens as L hiding (formatting, rangeFormatting)
import qualified Language.Haskell.LSP.VFS                as VFS
import           Text.Regex.TDFA.Text()

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

-- | Map a set of plugins to the underlying ghcide engine.  Main point is
-- IdePlugins are arranged by kind of operation, 'Plugin' is arranged by message
-- category ('Notifaction', 'Request' etc).
asGhcIdePlugin :: IdePlugins -> Plugin Config
asGhcIdePlugin :: IdePlugins -> Plugin Config
asGhcIdePlugin IdePlugins
mp =
    ([(PluginId, Rules ())] -> Plugin Config)
-> (PluginDescriptor -> Maybe (Rules ())) -> Plugin Config
forall b.
([(PluginId, b)] -> Plugin Config)
-> (PluginDescriptor -> Maybe b) -> Plugin Config
mkPlugin [(PluginId, Rules ())] -> Plugin Config
rulesPlugins (Rules () -> Maybe (Rules ())
forall a. a -> Maybe a
Just (Rules () -> Maybe (Rules ()))
-> (PluginDescriptor -> Rules ())
-> PluginDescriptor
-> Maybe (Rules ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PluginDescriptor -> Rules ()
pluginRules) Plugin Config -> Plugin Config -> Plugin Config
forall a. Semigroup a => a -> a -> a
<>
    ([(PluginId, [PluginCommand])] -> Plugin Config)
-> (PluginDescriptor -> Maybe [PluginCommand]) -> Plugin Config
forall b.
([(PluginId, b)] -> Plugin Config)
-> (PluginDescriptor -> Maybe b) -> Plugin Config
mkPlugin [(PluginId, [PluginCommand])] -> Plugin Config
executeCommandPlugins ([PluginCommand] -> Maybe [PluginCommand]
forall a. a -> Maybe a
Just ([PluginCommand] -> Maybe [PluginCommand])
-> (PluginDescriptor -> [PluginCommand])
-> PluginDescriptor
-> Maybe [PluginCommand]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PluginDescriptor -> [PluginCommand]
pluginCommands) Plugin Config -> Plugin Config -> Plugin Config
forall a. Semigroup a => a -> a -> a
<>
    ([(PluginId, CodeActionProvider)] -> Plugin Config)
-> (PluginDescriptor -> Maybe CodeActionProvider) -> Plugin Config
forall b.
([(PluginId, b)] -> Plugin Config)
-> (PluginDescriptor -> Maybe b) -> Plugin Config
mkPlugin [(PluginId, CodeActionProvider)] -> Plugin Config
codeActionPlugins     PluginDescriptor -> Maybe CodeActionProvider
pluginCodeActionProvider Plugin Config -> Plugin Config -> Plugin Config
forall a. Semigroup a => a -> a -> a
<>
    ([(PluginId, CodeLensProvider)] -> Plugin Config)
-> (PluginDescriptor -> Maybe CodeLensProvider) -> Plugin Config
forall b.
([(PluginId, b)] -> Plugin Config)
-> (PluginDescriptor -> Maybe b) -> Plugin Config
mkPlugin [(PluginId, CodeLensProvider)] -> Plugin Config
codeLensPlugins       PluginDescriptor -> Maybe CodeLensProvider
pluginCodeLensProvider Plugin Config -> Plugin Config -> Plugin Config
forall a. Semigroup a => a -> a -> a
<>
    -- Note: diagnostics are provided via Rules from pluginDiagnosticProvider
    ([(PluginId, HoverProvider)] -> Plugin Config)
-> (PluginDescriptor -> Maybe HoverProvider) -> Plugin Config
forall b.
([(PluginId, b)] -> Plugin Config)
-> (PluginDescriptor -> Maybe b) -> Plugin Config
mkPlugin [(PluginId, HoverProvider)] -> Plugin Config
hoverPlugins          PluginDescriptor -> Maybe HoverProvider
pluginHoverProvider Plugin Config -> Plugin Config -> Plugin Config
forall a. Semigroup a => a -> a -> a
<>
    ([(PluginId, SymbolsProvider)] -> Plugin Config)
-> (PluginDescriptor -> Maybe SymbolsProvider) -> Plugin Config
forall b.
([(PluginId, b)] -> Plugin Config)
-> (PluginDescriptor -> Maybe b) -> Plugin Config
mkPlugin [(PluginId, SymbolsProvider)] -> Plugin Config
symbolsPlugins        PluginDescriptor -> Maybe SymbolsProvider
pluginSymbolsProvider Plugin Config -> Plugin Config -> Plugin Config
forall a. Semigroup a => a -> a -> a
<>
    ([(PluginId, FormattingProvider IO)] -> Plugin Config)
-> (PluginDescriptor -> Maybe (FormattingProvider IO))
-> Plugin Config
forall b.
([(PluginId, b)] -> Plugin Config)
-> (PluginDescriptor -> Maybe b) -> Plugin Config
mkPlugin [(PluginId, FormattingProvider IO)] -> Plugin Config
formatterPlugins      PluginDescriptor -> Maybe (FormattingProvider IO)
pluginFormattingProvider Plugin Config -> Plugin Config -> Plugin Config
forall a. Semigroup a => a -> a -> a
<>
    ([(PluginId, CompletionProvider)] -> Plugin Config)
-> (PluginDescriptor -> Maybe CompletionProvider) -> Plugin Config
forall b.
([(PluginId, b)] -> Plugin Config)
-> (PluginDescriptor -> Maybe b) -> Plugin Config
mkPlugin [(PluginId, CompletionProvider)] -> Plugin Config
completionsPlugins    PluginDescriptor -> Maybe CompletionProvider
pluginCompletionProvider Plugin Config -> Plugin Config -> Plugin Config
forall a. Semigroup a => a -> a -> a
<>
    ([(PluginId, RenameProvider)] -> Plugin Config)
-> (PluginDescriptor -> Maybe RenameProvider) -> Plugin Config
forall b.
([(PluginId, b)] -> Plugin Config)
-> (PluginDescriptor -> Maybe b) -> Plugin Config
mkPlugin [(PluginId, RenameProvider)] -> Plugin Config
renamePlugins         PluginDescriptor -> Maybe RenameProvider
pluginRenameProvider
    where
        justs :: (a, Maybe b) -> [(a, b)]
justs (a
p, Just b
x)  = [(a
p, b
x)]
        justs (a
_, Maybe b
Nothing) = []

        ls :: [(PluginId, PluginDescriptor)]
ls = Map PluginId PluginDescriptor -> [(PluginId, PluginDescriptor)]
forall k a. Map k a -> [(k, a)]
Map.toList (IdePlugins -> Map PluginId PluginDescriptor
ipMap IdePlugins
mp)

        mkPlugin :: ([(PluginId, b)] -> Plugin Config) -> (PluginDescriptor -> Maybe b) -> Plugin Config
        mkPlugin :: ([(PluginId, b)] -> Plugin Config)
-> (PluginDescriptor -> Maybe b) -> Plugin Config
mkPlugin [(PluginId, b)] -> Plugin Config
maker PluginDescriptor -> Maybe b
selector =
          case ((PluginId, PluginDescriptor) -> [(PluginId, b)])
-> [(PluginId, PluginDescriptor)] -> [(PluginId, b)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(PluginId
pid, PluginDescriptor
p) -> (PluginId, Maybe b) -> [(PluginId, b)]
forall a b. (a, Maybe b) -> [(a, b)]
justs (PluginId
pid, PluginDescriptor -> Maybe b
selector PluginDescriptor
p)) [(PluginId, PluginDescriptor)]
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


pluginDescToIdePlugins :: [PluginDescriptor] -> IdePlugins
pluginDescToIdePlugins :: [PluginDescriptor] -> IdePlugins
pluginDescToIdePlugins [PluginDescriptor]
plugins = Map PluginId PluginDescriptor -> IdePlugins
IdePlugins (Map PluginId PluginDescriptor -> IdePlugins)
-> Map PluginId PluginDescriptor -> IdePlugins
forall a b. (a -> b) -> a -> b
$ [(PluginId, PluginDescriptor)] -> Map PluginId PluginDescriptor
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(PluginId, PluginDescriptor)] -> Map PluginId PluginDescriptor)
-> [(PluginId, PluginDescriptor)] -> Map PluginId PluginDescriptor
forall a b. (a -> b) -> a -> b
$ (PluginDescriptor -> (PluginId, PluginDescriptor))
-> [PluginDescriptor] -> [(PluginId, PluginDescriptor)]
forall a b. (a -> b) -> [a] -> [b]
map (\PluginDescriptor
p -> (PluginDescriptor -> PluginId
pluginId PluginDescriptor
p, PluginDescriptor
p)) [PluginDescriptor]
plugins

allLspCmdIds' :: T.Text -> IdePlugins -> [T.Text]
allLspCmdIds' :: Text -> IdePlugins -> [Text]
allLspCmdIds' Text
pid IdePlugins
mp = ([(PluginId, [PluginCommand])] -> [Text])
-> (PluginDescriptor -> Maybe [PluginCommand]) -> [Text]
mkPlugin (Text -> [(PluginId, [PluginCommand])] -> [Text]
allLspCmdIds Text
pid) ([PluginCommand] -> Maybe [PluginCommand]
forall a. a -> Maybe a
Just ([PluginCommand] -> Maybe [PluginCommand])
-> (PluginDescriptor -> [PluginCommand])
-> PluginDescriptor
-> Maybe [PluginCommand]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PluginDescriptor -> [PluginCommand]
pluginCommands)
    where
        justs :: (a, Maybe b) -> [(a, b)]
justs (a
p, Just b
x)  = [(a
p, b
x)]
        justs (a
_, Maybe b
Nothing) = []

        ls :: [(PluginId, PluginDescriptor)]
ls = Map PluginId PluginDescriptor -> [(PluginId, PluginDescriptor)]
forall k a. Map k a -> [(k, a)]
Map.toList (IdePlugins -> Map PluginId PluginDescriptor
ipMap IdePlugins
mp)

        mkPlugin :: ([(PluginId, [PluginCommand])] -> [Text])
-> (PluginDescriptor -> Maybe [PluginCommand]) -> [Text]
mkPlugin [(PluginId, [PluginCommand])] -> [Text]
maker PluginDescriptor -> Maybe [PluginCommand]
selector
            = [(PluginId, [PluginCommand])] -> [Text]
maker ([(PluginId, [PluginCommand])] -> [Text])
-> [(PluginId, [PluginCommand])] -> [Text]
forall a b. (a -> b) -> a -> b
$ ((PluginId, PluginDescriptor) -> [(PluginId, [PluginCommand])])
-> [(PluginId, PluginDescriptor)] -> [(PluginId, [PluginCommand])]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(PluginId
pid, PluginDescriptor
p) -> (PluginId, Maybe [PluginCommand]) -> [(PluginId, [PluginCommand])]
forall a b. (a, Maybe b) -> [(a, b)]
justs (PluginId
pid, PluginDescriptor -> Maybe [PluginCommand]
selector PluginDescriptor
p)) [(PluginId, PluginDescriptor)]
ls

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

rulesPlugins :: [(PluginId, Rules ())] -> Plugin Config
rulesPlugins :: [(PluginId, Rules ())] -> Plugin Config
rulesPlugins [(PluginId, Rules ())]
rs = Rules () -> PartialHandlers Config -> Plugin Config
forall c. Rules () -> PartialHandlers c -> Plugin c
Plugin Rules ()
rules PartialHandlers Config
forall a. Monoid a => a
mempty
    where
        rules :: Rules ()
rules = [Rules ()] -> Rules ()
forall a. Monoid a => [a] -> a
mconcat ([Rules ()] -> Rules ()) -> [Rules ()] -> Rules ()
forall a b. (a -> b) -> a -> b
$ ((PluginId, Rules ()) -> Rules ())
-> [(PluginId, Rules ())] -> [Rules ()]
forall a b. (a -> b) -> [a] -> [b]
map (PluginId, Rules ()) -> Rules ()
forall a b. (a, b) -> b
snd [(PluginId, Rules ())]
rs

codeActionPlugins :: [(PluginId, CodeActionProvider)] -> Plugin Config
codeActionPlugins :: [(PluginId, CodeActionProvider)] -> Plugin Config
codeActionPlugins [(PluginId, CodeActionProvider)]
cas = Rules () -> PartialHandlers Config -> Plugin Config
forall c. Rules () -> PartialHandlers c -> Plugin c
Plugin Rules ()
codeActionRules ([(PluginId, CodeActionProvider)] -> PartialHandlers Config
codeActionHandlers [(PluginId, CodeActionProvider)]
cas)

codeActionRules :: Rules ()
codeActionRules :: Rules ()
codeActionRules = Rules ()
forall a. Monoid a => a
mempty

codeActionHandlers :: [(PluginId, CodeActionProvider)] -> PartialHandlers Config
codeActionHandlers :: [(PluginId, CodeActionProvider)] -> PartialHandlers Config
codeActionHandlers [(PluginId, CodeActionProvider)]
cas = (WithMessage Config -> Handlers -> IO Handlers)
-> PartialHandlers Config
forall c.
(WithMessage c -> Handlers -> IO Handlers) -> PartialHandlers c
PartialHandlers ((WithMessage Config -> Handlers -> IO Handlers)
 -> PartialHandlers Config)
-> (WithMessage Config -> Handlers -> IO Handlers)
-> PartialHandlers Config
forall a b. (a -> b) -> a -> b
$ \WithMessage{(LspFuncs Config -> IdeState -> InitializeParams -> IO ())
-> Maybe (Handler InitializeRequest)
forall m req.
(Show m, Show req) =>
Maybe (Handler (NotificationMessage m req))
-> (LspFuncs Config -> IdeState -> req -> IO ())
-> Maybe (Handler (NotificationMessage m req))
forall m req resp.
(Show m, Show req) =>
(ResponseMessage resp -> FromServerMessage)
-> (LspFuncs Config
    -> IdeState -> req -> IO (Either ResponseError resp))
-> Maybe (Handler (RequestMessage m req resp))
forall m rm req resp newReqParams newReqBody.
(Show m, Show rm, Show req, Show newReqParams, Show newReqBody) =>
(ResponseMessage resp -> FromServerMessage)
-> (RequestMessage rm newReqParams newReqBody -> FromServerMessage)
-> (LspFuncs Config
    -> IdeState
    -> req
    -> IO (Either ResponseError resp, Maybe (rm, newReqParams)))
-> Maybe (Handler (RequestMessage m req resp))
$sel:withResponse:WithMessage :: forall c.
WithMessage c
-> forall m req resp.
   (Show m, Show req) =>
   (ResponseMessage resp -> FromServerMessage)
   -> (LspFuncs c
       -> IdeState -> req -> IO (Either ResponseError resp))
   -> Maybe (Handler (RequestMessage m req resp))
$sel:withNotification:WithMessage :: forall c.
WithMessage c
-> forall m req.
   (Show m, Show req) =>
   Maybe (Handler (NotificationMessage m req))
   -> (LspFuncs c -> IdeState -> req -> IO ())
   -> Maybe (Handler (NotificationMessage m req))
$sel:withResponseAndRequest:WithMessage :: forall c.
WithMessage c
-> forall m rm req resp newReqParams newReqBody.
   (Show m, Show rm, Show req, Show newReqParams, Show newReqBody) =>
   (ResponseMessage resp -> FromServerMessage)
   -> (RequestMessage rm newReqParams newReqBody -> FromServerMessage)
   -> (LspFuncs c
       -> IdeState
       -> req
       -> IO (Either ResponseError resp, Maybe (rm, newReqParams)))
   -> Maybe (Handler (RequestMessage m req resp))
$sel:withInitialize:WithMessage :: forall c.
WithMessage c
-> (LspFuncs c -> IdeState -> InitializeParams -> IO ())
-> Maybe (Handler InitializeRequest)
withInitialize :: (LspFuncs Config -> IdeState -> InitializeParams -> IO ())
-> Maybe (Handler InitializeRequest)
withResponseAndRequest :: forall m rm req resp newReqParams newReqBody.
(Show m, Show rm, Show req, Show newReqParams, Show newReqBody) =>
(ResponseMessage resp -> FromServerMessage)
-> (RequestMessage rm newReqParams newReqBody -> FromServerMessage)
-> (LspFuncs Config
    -> IdeState
    -> req
    -> IO (Either ResponseError resp, Maybe (rm, newReqParams)))
-> Maybe (Handler (RequestMessage m req resp))
withNotification :: forall m req.
(Show m, Show req) =>
Maybe (Handler (NotificationMessage m req))
-> (LspFuncs Config -> IdeState -> req -> IO ())
-> Maybe (Handler (NotificationMessage m req))
withResponse :: forall m req resp.
(Show m, Show req) =>
(ResponseMessage resp -> FromServerMessage)
-> (LspFuncs Config
    -> IdeState -> req -> IO (Either ResponseError resp))
-> Maybe (Handler (RequestMessage m req resp))
..} Handlers
x -> Handlers -> IO Handlers
forall (m :: * -> *) a. Monad m => a -> m a
return Handlers
x
    { codeActionHandler :: Maybe (Handler CodeActionRequest)
LSP.codeActionHandler
        = (ResponseMessage (List CAResult) -> FromServerMessage)
-> (LspFuncs Config
    -> IdeState
    -> CodeActionParams
    -> IO (Either ResponseError (List CAResult)))
-> Maybe (Handler CodeActionRequest)
forall m req resp.
(Show m, Show req) =>
(ResponseMessage resp -> FromServerMessage)
-> (LspFuncs Config
    -> IdeState -> req -> IO (Either ResponseError resp))
-> Maybe (Handler (RequestMessage m req resp))
withResponse ResponseMessage (List CAResult) -> FromServerMessage
RspCodeAction ([(PluginId, CodeActionProvider)]
-> LspFuncs Config
-> IdeState
-> CodeActionParams
-> IO (Either ResponseError (List CAResult))
makeCodeAction [(PluginId, CodeActionProvider)]
cas)
    }

makeCodeAction :: [(PluginId, CodeActionProvider)]
      -> LSP.LspFuncs Config -> IdeState
      -> CodeActionParams
      -> IO (Either ResponseError (List CAResult))
makeCodeAction :: [(PluginId, CodeActionProvider)]
-> LspFuncs Config
-> IdeState
-> CodeActionParams
-> IO (Either ResponseError (List CAResult))
makeCodeAction [(PluginId, CodeActionProvider)]
cas LspFuncs Config
lf IdeState
ideState (CodeActionParams TextDocumentIdentifier
docId Range
range CodeActionContext
context Maybe ProgressToken
_) = do
    let caps :: ClientCapabilities
caps = LspFuncs Config -> ClientCapabilities
forall c. LspFuncs c -> ClientCapabilities
LSP.clientCapabilities LspFuncs Config
lf
        unL :: List a -> [a]
unL (List [a]
ls) = [a]
ls
    [Either ResponseError (List CAResult)]
r <- ((PluginId, CodeActionProvider)
 -> IO (Either ResponseError (List CAResult)))
-> [(PluginId, CodeActionProvider)]
-> IO [Either ResponseError (List CAResult)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(PluginId
pid,CodeActionProvider
provider) -> CodeActionProvider
provider LspFuncs Config
lf IdeState
ideState PluginId
pid TextDocumentIdentifier
docId Range
range CodeActionContext
context) [(PluginId, CodeActionProvider)]
cas
    let actions :: [CAResult]
actions = (CAResult -> Bool) -> [CAResult] -> [CAResult]
forall a. (a -> Bool) -> [a] -> [a]
filter CAResult -> Bool
wasRequested ([CAResult] -> [CAResult])
-> ([[CAResult]] -> [CAResult]) -> [[CAResult]] -> [CAResult]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[CAResult]] -> [CAResult]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[CAResult]] -> [CAResult]) -> [[CAResult]] -> [CAResult]
forall a b. (a -> b) -> a -> b
$ (List CAResult -> [CAResult]) -> [List CAResult] -> [[CAResult]]
forall a b. (a -> b) -> [a] -> [b]
map List CAResult -> [CAResult]
forall a. List a -> [a]
unL ([List CAResult] -> [[CAResult]])
-> [List CAResult] -> [[CAResult]]
forall a b. (a -> b) -> a -> b
$ [Either ResponseError (List CAResult)] -> [List CAResult]
forall a b. [Either a b] -> [b]
rights [Either ResponseError (List CAResult)]
r
    List CAResult
res <- ClientCapabilities -> [CAResult] -> IO (List CAResult)
send ClientCapabilities
caps [CAResult]
actions
    Either ResponseError (List CAResult)
-> IO (Either ResponseError (List CAResult))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ResponseError (List CAResult)
 -> IO (Either ResponseError (List CAResult)))
-> Either ResponseError (List CAResult)
-> IO (Either ResponseError (List CAResult))
forall a b. (a -> b) -> a -> b
$ List CAResult -> Either ResponseError (List CAResult)
forall a b. b -> Either a b
Right List CAResult
res
  where
    wasRequested :: CAResult -> Bool
    wasRequested :: CAResult -> Bool
wasRequested (CACommand Command
_) = Bool
True
    wasRequested (CACodeAction CodeAction
ca)
      | Maybe (List CodeActionKind)
Nothing <- CodeActionContext -> Maybe (List CodeActionKind)
only CodeActionContext
context = Bool
True
      | Just (List [CodeActionKind]
allowed) <- CodeActionContext -> Maybe (List CodeActionKind)
only CodeActionContext
context
      , Just CodeActionKind
caKind <- CodeAction
ca CodeAction
-> Getting (Maybe CodeActionKind) CodeAction (Maybe CodeActionKind)
-> Maybe CodeActionKind
forall s a. s -> Getting a s a -> a
^. Getting (Maybe CodeActionKind) CodeAction (Maybe CodeActionKind)
forall s a. HasKind s a => Lens' s a
kind = CodeActionKind
caKind CodeActionKind -> [CodeActionKind] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CodeActionKind]
allowed
      | Bool
otherwise = Bool
False

    wrapCodeAction :: C.ClientCapabilities -> CAResult -> IO (Maybe CAResult)
    wrapCodeAction :: ClientCapabilities -> CAResult -> IO (Maybe CAResult)
wrapCodeAction ClientCapabilities
_ (CACommand Command
cmd) = Maybe CAResult -> IO (Maybe CAResult)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe CAResult -> IO (Maybe CAResult))
-> Maybe CAResult -> IO (Maybe CAResult)
forall a b. (a -> b) -> a -> b
$ CAResult -> Maybe CAResult
forall a. a -> Maybe a
Just (Command -> CAResult
CACommand Command
cmd)
    wrapCodeAction ClientCapabilities
caps (CACodeAction CodeAction
action) = do

      let (C.ClientCapabilities Maybe WorkspaceClientCapabilities
_ Maybe TextDocumentClientCapabilities
textDocCaps Maybe WindowClientCapabilities
_ Maybe Object
_) = ClientCapabilities
caps
      let literalSupport :: Maybe CodeActionLiteralSupport
literalSupport = Maybe TextDocumentClientCapabilities
textDocCaps Maybe TextDocumentClientCapabilities
-> (TextDocumentClientCapabilities
    -> Maybe CodeActionClientCapabilities)
-> Maybe CodeActionClientCapabilities
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TextDocumentClientCapabilities
-> Maybe CodeActionClientCapabilities
C._codeAction Maybe CodeActionClientCapabilities
-> (CodeActionClientCapabilities -> Maybe CodeActionLiteralSupport)
-> Maybe CodeActionLiteralSupport
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CodeActionClientCapabilities -> Maybe CodeActionLiteralSupport
C._codeActionLiteralSupport

      case Maybe CodeActionLiteralSupport
literalSupport of
        Maybe CodeActionLiteralSupport
Nothing -> do
            let cmdParams :: [Value]
cmdParams = [FallbackCodeActionParams -> Value
forall a. ToJSON a => a -> Value
J.toJSON (Maybe WorkspaceEdit -> Maybe Command -> FallbackCodeActionParams
FallbackCodeActionParams (CodeAction
action CodeAction
-> Getting (Maybe WorkspaceEdit) CodeAction (Maybe WorkspaceEdit)
-> Maybe WorkspaceEdit
forall s a. s -> Getting a s a -> a
^. Getting (Maybe WorkspaceEdit) CodeAction (Maybe WorkspaceEdit)
forall s a. HasEdit s a => Lens' s a
edit) (CodeAction
action CodeAction
-> Getting (Maybe Command) CodeAction (Maybe Command)
-> Maybe Command
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Command) CodeAction (Maybe Command)
forall s a. HasCommand s a => Lens' s a
command))]
            Command
cmd <- PluginId -> CommandId -> Text -> Maybe [Value] -> IO Command
mkLspCommand PluginId
"hls" CommandId
"fallbackCodeAction" (CodeAction
action CodeAction -> Getting Text CodeAction Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text CodeAction Text
forall s a. HasTitle s a => Lens' s a
title) ([Value] -> Maybe [Value]
forall a. a -> Maybe a
Just [Value]
cmdParams)
            Maybe CAResult -> IO (Maybe CAResult)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe CAResult -> IO (Maybe CAResult))
-> Maybe CAResult -> IO (Maybe CAResult)
forall a b. (a -> b) -> a -> b
$ CAResult -> Maybe CAResult
forall a. a -> Maybe a
Just (Command -> CAResult
CACommand Command
cmd)
        Just CodeActionLiteralSupport
_ -> Maybe CAResult -> IO (Maybe CAResult)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe CAResult -> IO (Maybe CAResult))
-> Maybe CAResult -> IO (Maybe CAResult)
forall a b. (a -> b) -> a -> b
$ CAResult -> Maybe CAResult
forall a. a -> Maybe a
Just (CodeAction -> CAResult
CACodeAction CodeAction
action)

    send :: C.ClientCapabilities -> [CAResult] -> IO (List CAResult)
    send :: ClientCapabilities -> [CAResult] -> IO (List CAResult)
send ClientCapabilities
caps [CAResult]
codeActions = [CAResult] -> List CAResult
forall a. [a] -> List a
List ([CAResult] -> List CAResult)
-> ([Maybe CAResult] -> [CAResult])
-> [Maybe CAResult]
-> List CAResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe CAResult] -> [CAResult]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe CAResult] -> List CAResult)
-> IO [Maybe CAResult] -> IO (List CAResult)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (CAResult -> IO (Maybe CAResult))
-> [CAResult] -> IO [Maybe CAResult]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ClientCapabilities -> CAResult -> IO (Maybe CAResult)
wrapCodeAction ClientCapabilities
caps) [CAResult]
codeActions

data FallbackCodeActionParams =
  FallbackCodeActionParams
    { FallbackCodeActionParams -> Maybe WorkspaceEdit
fallbackWorkspaceEdit :: Maybe WorkspaceEdit
    , FallbackCodeActionParams -> Maybe Command
fallbackCommand       :: Maybe Command
    }
  deriving ((forall x.
 FallbackCodeActionParams -> Rep FallbackCodeActionParams x)
-> (forall x.
    Rep FallbackCodeActionParams x -> FallbackCodeActionParams)
-> Generic FallbackCodeActionParams
forall x.
Rep FallbackCodeActionParams x -> FallbackCodeActionParams
forall x.
FallbackCodeActionParams -> Rep FallbackCodeActionParams x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x.
Rep FallbackCodeActionParams x -> FallbackCodeActionParams
$cfrom :: forall x.
FallbackCodeActionParams -> Rep FallbackCodeActionParams x
Generic, [FallbackCodeActionParams] -> Encoding
[FallbackCodeActionParams] -> Value
FallbackCodeActionParams -> Encoding
FallbackCodeActionParams -> Value
(FallbackCodeActionParams -> Value)
-> (FallbackCodeActionParams -> Encoding)
-> ([FallbackCodeActionParams] -> Value)
-> ([FallbackCodeActionParams] -> Encoding)
-> ToJSON FallbackCodeActionParams
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [FallbackCodeActionParams] -> Encoding
$ctoEncodingList :: [FallbackCodeActionParams] -> Encoding
toJSONList :: [FallbackCodeActionParams] -> Value
$ctoJSONList :: [FallbackCodeActionParams] -> Value
toEncoding :: FallbackCodeActionParams -> Encoding
$ctoEncoding :: FallbackCodeActionParams -> Encoding
toJSON :: FallbackCodeActionParams -> Value
$ctoJSON :: FallbackCodeActionParams -> Value
J.ToJSON, Value -> Parser [FallbackCodeActionParams]
Value -> Parser FallbackCodeActionParams
(Value -> Parser FallbackCodeActionParams)
-> (Value -> Parser [FallbackCodeActionParams])
-> FromJSON FallbackCodeActionParams
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [FallbackCodeActionParams]
$cparseJSONList :: Value -> Parser [FallbackCodeActionParams]
parseJSON :: Value -> Parser FallbackCodeActionParams
$cparseJSON :: Value -> Parser FallbackCodeActionParams
J.FromJSON)

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

codeLensPlugins :: [(PluginId, CodeLensProvider)] -> Plugin Config
codeLensPlugins :: [(PluginId, CodeLensProvider)] -> Plugin Config
codeLensPlugins [(PluginId, CodeLensProvider)]
cas = Rules () -> PartialHandlers Config -> Plugin Config
forall c. Rules () -> PartialHandlers c -> Plugin c
Plugin Rules ()
codeLensRules ([(PluginId, CodeLensProvider)] -> PartialHandlers Config
codeLensHandlers [(PluginId, CodeLensProvider)]
cas)

codeLensRules :: Rules ()
codeLensRules :: Rules ()
codeLensRules = Rules ()
forall a. Monoid a => a
mempty

codeLensHandlers :: [(PluginId, CodeLensProvider)] -> PartialHandlers Config
codeLensHandlers :: [(PluginId, CodeLensProvider)] -> PartialHandlers Config
codeLensHandlers [(PluginId, CodeLensProvider)]
cas = (WithMessage Config -> Handlers -> IO Handlers)
-> PartialHandlers Config
forall c.
(WithMessage c -> Handlers -> IO Handlers) -> PartialHandlers c
PartialHandlers ((WithMessage Config -> Handlers -> IO Handlers)
 -> PartialHandlers Config)
-> (WithMessage Config -> Handlers -> IO Handlers)
-> PartialHandlers Config
forall a b. (a -> b) -> a -> b
$ \WithMessage{(LspFuncs Config -> IdeState -> InitializeParams -> IO ())
-> Maybe (Handler InitializeRequest)
forall m req.
(Show m, Show req) =>
Maybe (Handler (NotificationMessage m req))
-> (LspFuncs Config -> IdeState -> req -> IO ())
-> Maybe (Handler (NotificationMessage m req))
forall m req resp.
(Show m, Show req) =>
(ResponseMessage resp -> FromServerMessage)
-> (LspFuncs Config
    -> IdeState -> req -> IO (Either ResponseError resp))
-> Maybe (Handler (RequestMessage m req resp))
forall m rm req resp newReqParams newReqBody.
(Show m, Show rm, Show req, Show newReqParams, Show newReqBody) =>
(ResponseMessage resp -> FromServerMessage)
-> (RequestMessage rm newReqParams newReqBody -> FromServerMessage)
-> (LspFuncs Config
    -> IdeState
    -> req
    -> IO (Either ResponseError resp, Maybe (rm, newReqParams)))
-> Maybe (Handler (RequestMessage m req resp))
withInitialize :: (LspFuncs Config -> IdeState -> InitializeParams -> IO ())
-> Maybe (Handler InitializeRequest)
withResponseAndRequest :: forall m rm req resp newReqParams newReqBody.
(Show m, Show rm, Show req, Show newReqParams, Show newReqBody) =>
(ResponseMessage resp -> FromServerMessage)
-> (RequestMessage rm newReqParams newReqBody -> FromServerMessage)
-> (LspFuncs Config
    -> IdeState
    -> req
    -> IO (Either ResponseError resp, Maybe (rm, newReqParams)))
-> Maybe (Handler (RequestMessage m req resp))
withNotification :: forall m req.
(Show m, Show req) =>
Maybe (Handler (NotificationMessage m req))
-> (LspFuncs Config -> IdeState -> req -> IO ())
-> Maybe (Handler (NotificationMessage m req))
withResponse :: forall m req resp.
(Show m, Show req) =>
(ResponseMessage resp -> FromServerMessage)
-> (LspFuncs Config
    -> IdeState -> req -> IO (Either ResponseError resp))
-> Maybe (Handler (RequestMessage m req resp))
$sel:withResponse:WithMessage :: forall c.
WithMessage c
-> forall m req resp.
   (Show m, Show req) =>
   (ResponseMessage resp -> FromServerMessage)
   -> (LspFuncs c
       -> IdeState -> req -> IO (Either ResponseError resp))
   -> Maybe (Handler (RequestMessage m req resp))
$sel:withNotification:WithMessage :: forall c.
WithMessage c
-> forall m req.
   (Show m, Show req) =>
   Maybe (Handler (NotificationMessage m req))
   -> (LspFuncs c -> IdeState -> req -> IO ())
   -> Maybe (Handler (NotificationMessage m req))
$sel:withResponseAndRequest:WithMessage :: forall c.
WithMessage c
-> forall m rm req resp newReqParams newReqBody.
   (Show m, Show rm, Show req, Show newReqParams, Show newReqBody) =>
   (ResponseMessage resp -> FromServerMessage)
   -> (RequestMessage rm newReqParams newReqBody -> FromServerMessage)
   -> (LspFuncs c
       -> IdeState
       -> req
       -> IO (Either ResponseError resp, Maybe (rm, newReqParams)))
   -> Maybe (Handler (RequestMessage m req resp))
$sel:withInitialize:WithMessage :: forall c.
WithMessage c
-> (LspFuncs c -> IdeState -> InitializeParams -> IO ())
-> Maybe (Handler InitializeRequest)
..} Handlers
x -> Handlers -> IO Handlers
forall (m :: * -> *) a. Monad m => a -> m a
return Handlers
x
    { codeLensHandler :: Maybe (Handler CodeLensRequest)
LSP.codeLensHandler
        = (ResponseMessage (List CodeLens) -> FromServerMessage)
-> (LspFuncs Config
    -> IdeState
    -> CodeLensParams
    -> IO (Either ResponseError (List CodeLens)))
-> Maybe (Handler CodeLensRequest)
forall m req resp.
(Show m, Show req) =>
(ResponseMessage resp -> FromServerMessage)
-> (LspFuncs Config
    -> IdeState -> req -> IO (Either ResponseError resp))
-> Maybe (Handler (RequestMessage m req resp))
withResponse ResponseMessage (List CodeLens) -> FromServerMessage
RspCodeLens ([(PluginId, CodeLensProvider)]
-> LspFuncs Config
-> IdeState
-> CodeLensParams
-> IO (Either ResponseError (List CodeLens))
makeCodeLens [(PluginId, CodeLensProvider)]
cas)
    }

makeCodeLens :: [(PluginId, CodeLensProvider)]
      -> LSP.LspFuncs Config
      -> IdeState
      -> CodeLensParams
      -> IO (Either ResponseError (List CodeLens))
makeCodeLens :: [(PluginId, CodeLensProvider)]
-> LspFuncs Config
-> IdeState
-> CodeLensParams
-> IO (Either ResponseError (List CodeLens))
makeCodeLens [(PluginId, CodeLensProvider)]
cas LspFuncs Config
lf IdeState
ideState CodeLensParams
params = do
    Logger -> Text -> IO ()
logInfo (IdeState -> Logger
ideLogger IdeState
ideState) Text
"Plugin.makeCodeLens (ideLogger)" -- AZ
    let
      makeLens :: (PluginId, CodeLensProvider)
-> IO (PluginId, Either ResponseError (List CodeLens))
makeLens (PluginId
pid, CodeLensProvider
provider) = do
          Either ResponseError (List CodeLens)
r <- CodeLensProvider
provider LspFuncs Config
lf IdeState
ideState PluginId
pid CodeLensParams
params
          (PluginId, Either ResponseError (List CodeLens))
-> IO (PluginId, Either ResponseError (List CodeLens))
forall (m :: * -> *) a. Monad m => a -> m a
return (PluginId
pid, Either ResponseError (List CodeLens)
r)
      breakdown :: [(PluginId, Either ResponseError a)] -> ([(PluginId, ResponseError)], [(PluginId, a)])
      breakdown :: [(PluginId, Either ResponseError a)]
-> ([(PluginId, ResponseError)], [(PluginId, a)])
breakdown [(PluginId, Either ResponseError a)]
ls = (((PluginId, Either ResponseError a) -> [(PluginId, ResponseError)])
-> [(PluginId, Either ResponseError a)]
-> [(PluginId, ResponseError)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (PluginId, Either ResponseError a) -> [(PluginId, ResponseError)]
forall a b b. (a, Either b b) -> [(a, b)]
doOneLeft [(PluginId, Either ResponseError a)]
ls, ((PluginId, Either ResponseError a) -> [(PluginId, a)])
-> [(PluginId, Either ResponseError a)] -> [(PluginId, a)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (PluginId, Either ResponseError a) -> [(PluginId, a)]
forall a a b. (a, Either a b) -> [(a, b)]
doOneRight [(PluginId, Either ResponseError a)]
ls)
        where
          doOneLeft :: (a, Either b b) -> [(a, b)]
doOneLeft (a
pid, Left b
err) = [(a
pid,b
err)]
          doOneLeft (a
_, Right b
_) = []

          doOneRight :: (a, Either a b) -> [(a, b)]
doOneRight (a
pid, Right b
a) = [(a
pid,b
a)]
          doOneRight (a
_, Left a
_) = []

    [(PluginId, Either ResponseError (List CodeLens))]
r <- ((PluginId, CodeLensProvider)
 -> IO (PluginId, Either ResponseError (List CodeLens)))
-> [(PluginId, CodeLensProvider)]
-> IO [(PluginId, Either ResponseError (List CodeLens))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (PluginId, CodeLensProvider)
-> IO (PluginId, Either ResponseError (List CodeLens))
makeLens [(PluginId, CodeLensProvider)]
cas
    case [(PluginId, Either ResponseError (List CodeLens))]
-> ([(PluginId, ResponseError)], [(PluginId, List CodeLens)])
forall a.
[(PluginId, Either ResponseError a)]
-> ([(PluginId, ResponseError)], [(PluginId, a)])
breakdown [(PluginId, Either ResponseError (List CodeLens))]
r of
        ([],[]) -> Either ResponseError (List CodeLens)
-> IO (Either ResponseError (List CodeLens))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ResponseError (List CodeLens)
 -> IO (Either ResponseError (List CodeLens)))
-> Either ResponseError (List CodeLens)
-> IO (Either ResponseError (List CodeLens))
forall a b. (a -> b) -> a -> b
$ List CodeLens -> Either ResponseError (List CodeLens)
forall a b. b -> Either a b
Right (List CodeLens -> Either ResponseError (List CodeLens))
-> List CodeLens -> Either ResponseError (List CodeLens)
forall a b. (a -> b) -> a -> b
$ [CodeLens] -> List CodeLens
forall a. [a] -> List a
List []
        ([(PluginId, ResponseError)]
es,[]) -> Either ResponseError (List CodeLens)
-> IO (Either ResponseError (List CodeLens))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ResponseError (List CodeLens)
 -> IO (Either ResponseError (List CodeLens)))
-> Either ResponseError (List CodeLens)
-> IO (Either ResponseError (List CodeLens))
forall a b. (a -> b) -> a -> b
$ ResponseError -> Either ResponseError (List CodeLens)
forall a b. a -> Either a b
Left (ResponseError -> Either ResponseError (List CodeLens))
-> ResponseError -> Either ResponseError (List CodeLens)
forall a b. (a -> b) -> a -> b
$ ErrorCode -> Text -> Maybe Value -> ResponseError
ResponseError ErrorCode
InternalError (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"codeLens failed:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [(PluginId, ResponseError)] -> String
forall a. Show a => a -> String
show [(PluginId, ResponseError)]
es) Maybe Value
forall a. Maybe a
Nothing
        ([(PluginId, ResponseError)]
_,[(PluginId, List CodeLens)]
rs) -> Either ResponseError (List CodeLens)
-> IO (Either ResponseError (List CodeLens))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ResponseError (List CodeLens)
 -> IO (Either ResponseError (List CodeLens)))
-> Either ResponseError (List CodeLens)
-> IO (Either ResponseError (List CodeLens))
forall a b. (a -> b) -> a -> b
$ List CodeLens -> Either ResponseError (List CodeLens)
forall a b. b -> Either a b
Right (List CodeLens -> Either ResponseError (List CodeLens))
-> List CodeLens -> Either ResponseError (List CodeLens)
forall a b. (a -> b) -> a -> b
$ [CodeLens] -> List CodeLens
forall a. [a] -> List a
List (((PluginId, List CodeLens) -> [CodeLens])
-> [(PluginId, List CodeLens)] -> [CodeLens]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(PluginId
_,List [CodeLens]
cs) -> [CodeLens]
cs) [(PluginId, List CodeLens)]
rs)

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

executeCommandPlugins :: [(PluginId, [PluginCommand])] -> Plugin Config
executeCommandPlugins :: [(PluginId, [PluginCommand])] -> Plugin Config
executeCommandPlugins [(PluginId, [PluginCommand])]
ecs = Rules () -> PartialHandlers Config -> Plugin Config
forall c. Rules () -> PartialHandlers c -> Plugin c
Plugin Rules ()
forall a. Monoid a => a
mempty ([(PluginId, [PluginCommand])] -> PartialHandlers Config
executeCommandHandlers [(PluginId, [PluginCommand])]
ecs)

executeCommandHandlers :: [(PluginId, [PluginCommand])] -> PartialHandlers Config
executeCommandHandlers :: [(PluginId, [PluginCommand])] -> PartialHandlers Config
executeCommandHandlers [(PluginId, [PluginCommand])]
ecs = (WithMessage Config -> Handlers -> IO Handlers)
-> PartialHandlers Config
forall c.
(WithMessage c -> Handlers -> IO Handlers) -> PartialHandlers c
PartialHandlers ((WithMessage Config -> Handlers -> IO Handlers)
 -> PartialHandlers Config)
-> (WithMessage Config -> Handlers -> IO Handlers)
-> PartialHandlers Config
forall a b. (a -> b) -> a -> b
$ \WithMessage{(LspFuncs Config -> IdeState -> InitializeParams -> IO ())
-> Maybe (Handler InitializeRequest)
forall m req.
(Show m, Show req) =>
Maybe (Handler (NotificationMessage m req))
-> (LspFuncs Config -> IdeState -> req -> IO ())
-> Maybe (Handler (NotificationMessage m req))
forall m req resp.
(Show m, Show req) =>
(ResponseMessage resp -> FromServerMessage)
-> (LspFuncs Config
    -> IdeState -> req -> IO (Either ResponseError resp))
-> Maybe (Handler (RequestMessage m req resp))
forall m rm req resp newReqParams newReqBody.
(Show m, Show rm, Show req, Show newReqParams, Show newReqBody) =>
(ResponseMessage resp -> FromServerMessage)
-> (RequestMessage rm newReqParams newReqBody -> FromServerMessage)
-> (LspFuncs Config
    -> IdeState
    -> req
    -> IO (Either ResponseError resp, Maybe (rm, newReqParams)))
-> Maybe (Handler (RequestMessage m req resp))
withInitialize :: (LspFuncs Config -> IdeState -> InitializeParams -> IO ())
-> Maybe (Handler InitializeRequest)
withResponseAndRequest :: forall m rm req resp newReqParams newReqBody.
(Show m, Show rm, Show req, Show newReqParams, Show newReqBody) =>
(ResponseMessage resp -> FromServerMessage)
-> (RequestMessage rm newReqParams newReqBody -> FromServerMessage)
-> (LspFuncs Config
    -> IdeState
    -> req
    -> IO (Either ResponseError resp, Maybe (rm, newReqParams)))
-> Maybe (Handler (RequestMessage m req resp))
withNotification :: forall m req.
(Show m, Show req) =>
Maybe (Handler (NotificationMessage m req))
-> (LspFuncs Config -> IdeState -> req -> IO ())
-> Maybe (Handler (NotificationMessage m req))
withResponse :: forall m req resp.
(Show m, Show req) =>
(ResponseMessage resp -> FromServerMessage)
-> (LspFuncs Config
    -> IdeState -> req -> IO (Either ResponseError resp))
-> Maybe (Handler (RequestMessage m req resp))
$sel:withResponse:WithMessage :: forall c.
WithMessage c
-> forall m req resp.
   (Show m, Show req) =>
   (ResponseMessage resp -> FromServerMessage)
   -> (LspFuncs c
       -> IdeState -> req -> IO (Either ResponseError resp))
   -> Maybe (Handler (RequestMessage m req resp))
$sel:withNotification:WithMessage :: forall c.
WithMessage c
-> forall m req.
   (Show m, Show req) =>
   Maybe (Handler (NotificationMessage m req))
   -> (LspFuncs c -> IdeState -> req -> IO ())
   -> Maybe (Handler (NotificationMessage m req))
$sel:withResponseAndRequest:WithMessage :: forall c.
WithMessage c
-> forall m rm req resp newReqParams newReqBody.
   (Show m, Show rm, Show req, Show newReqParams, Show newReqBody) =>
   (ResponseMessage resp -> FromServerMessage)
   -> (RequestMessage rm newReqParams newReqBody -> FromServerMessage)
   -> (LspFuncs c
       -> IdeState
       -> req
       -> IO (Either ResponseError resp, Maybe (rm, newReqParams)))
   -> Maybe (Handler (RequestMessage m req resp))
$sel:withInitialize:WithMessage :: forall c.
WithMessage c
-> (LspFuncs c -> IdeState -> InitializeParams -> IO ())
-> Maybe (Handler InitializeRequest)
..} Handlers
x -> Handlers -> IO Handlers
forall (m :: * -> *) a. Monad m => a -> m a
return Handlers
x{
    executeCommandHandler :: Maybe (Handler ExecuteCommandRequest)
LSP.executeCommandHandler = (ResponseMessage Value -> FromServerMessage)
-> (RequestMessage
      ServerMethod
      ApplyWorkspaceEditParams
      ApplyWorkspaceEditResponseBody
    -> FromServerMessage)
-> (LspFuncs Config
    -> IdeState
    -> ExecuteCommandParams
    -> IO
         (Either ResponseError Value,
          Maybe (ServerMethod, ApplyWorkspaceEditParams)))
-> Maybe (Handler ExecuteCommandRequest)
forall m rm req resp newReqParams newReqBody.
(Show m, Show rm, Show req, Show newReqParams, Show newReqBody) =>
(ResponseMessage resp -> FromServerMessage)
-> (RequestMessage rm newReqParams newReqBody -> FromServerMessage)
-> (LspFuncs Config
    -> IdeState
    -> req
    -> IO (Either ResponseError resp, Maybe (rm, newReqParams)))
-> Maybe (Handler (RequestMessage m req resp))
withResponseAndRequest ResponseMessage Value -> FromServerMessage
RspExecuteCommand RequestMessage
  ServerMethod
  ApplyWorkspaceEditParams
  ApplyWorkspaceEditResponseBody
-> FromServerMessage
ReqApplyWorkspaceEdit ([(PluginId, [PluginCommand])]
-> LspFuncs Config
-> IdeState
-> ExecuteCommandParams
-> IO
     (Either ResponseError Value,
      Maybe (ServerMethod, ApplyWorkspaceEditParams))
makeExecuteCommands [(PluginId, [PluginCommand])]
ecs)
    }

-- type ExecuteCommandProvider = IdeState
--                             -> ExecuteCommandParams
--                             -> IO (Either ResponseError Value, Maybe (ServerMethod, ApplyWorkspaceEditParams))
makeExecuteCommands :: [(PluginId, [PluginCommand])] -> LSP.LspFuncs Config -> ExecuteCommandProvider
makeExecuteCommands :: [(PluginId, [PluginCommand])]
-> LspFuncs Config
-> IdeState
-> ExecuteCommandParams
-> IO
     (Either ResponseError Value,
      Maybe (ServerMethod, ApplyWorkspaceEditParams))
makeExecuteCommands [(PluginId, [PluginCommand])]
ecs LspFuncs Config
lf IdeState
ide = (ExecuteCommandParams
 -> IO
      (Either ResponseError Value,
       Maybe (ServerMethod, ApplyWorkspaceEditParams)))
-> ExecuteCommandParams
-> IO
     (Either ResponseError Value,
      Maybe (ServerMethod, ApplyWorkspaceEditParams))
forall a b.
(a -> IO (Either ResponseError Value, Maybe b))
-> a -> IO (Either ResponseError Value, Maybe b)
wrapUnhandledExceptions ((ExecuteCommandParams
  -> IO
       (Either ResponseError Value,
        Maybe (ServerMethod, ApplyWorkspaceEditParams)))
 -> ExecuteCommandParams
 -> IO
      (Either ResponseError Value,
       Maybe (ServerMethod, ApplyWorkspaceEditParams)))
-> (ExecuteCommandParams
    -> IO
         (Either ResponseError Value,
          Maybe (ServerMethod, ApplyWorkspaceEditParams)))
-> ExecuteCommandParams
-> IO
     (Either ResponseError Value,
      Maybe (ServerMethod, ApplyWorkspaceEditParams))
forall a b. (a -> b) -> a -> b
$ do
  let
      pluginMap :: Map PluginId [PluginCommand]
pluginMap = [(PluginId, [PluginCommand])] -> Map PluginId [PluginCommand]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(PluginId, [PluginCommand])]
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

      execCmd :: ExecuteCommandParams -> IO (Either ResponseError J.Value, Maybe (ServerMethod, ApplyWorkspaceEditParams))
      execCmd :: ExecuteCommandParams
-> IO
     (Either ResponseError Value,
      Maybe (ServerMethod, ApplyWorkspaceEditParams))
execCmd (ExecuteCommandParams Text
cmdId Maybe (List Value)
args Maybe ProgressToken
_) = do
        -- The parameters to the HIE command are always the first element
        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 -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe WorkspaceEdit
mEdit ((WorkspaceEdit -> IO ()) -> IO ())
-> (WorkspaceEdit -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \WorkspaceEdit
edit -> do
                  let eParams :: ApplyWorkspaceEditParams
eParams = WorkspaceEdit -> ApplyWorkspaceEditParams
J.ApplyWorkspaceEditParams WorkspaceEdit
edit
                  LspId
reqId <- LspFuncs Config -> IO LspId
forall c. LspFuncs c -> IO LspId
LSP.getNextReqId LspFuncs Config
lf
                  LspFuncs Config -> SendFunc
forall c. LspFuncs c -> SendFunc
LSP.sendFunc LspFuncs Config
lf SendFunc -> SendFunc
forall a b. (a -> b) -> a -> b
$ RequestMessage
  ServerMethod
  ApplyWorkspaceEditParams
  ApplyWorkspaceEditResponseBody
-> FromServerMessage
ReqApplyWorkspaceEdit (RequestMessage
   ServerMethod
   ApplyWorkspaceEditParams
   ApplyWorkspaceEditResponseBody
 -> FromServerMessage)
-> RequestMessage
     ServerMethod
     ApplyWorkspaceEditParams
     ApplyWorkspaceEditResponseBody
-> FromServerMessage
forall a b. (a -> b) -> a -> b
$ Text
-> LspId
-> ServerMethod
-> ApplyWorkspaceEditParams
-> RequestMessage
     ServerMethod
     ApplyWorkspaceEditParams
     ApplyWorkspaceEditResponseBody
forall m req resp.
Text -> LspId -> m -> req -> RequestMessage m req resp
RequestMessage Text
"2.0" LspId
reqId ServerMethod
WorkspaceApplyEdit ApplyWorkspaceEditParams
eParams

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

              J.Error String
_str -> (Either ResponseError Value,
 Maybe (ServerMethod, ApplyWorkspaceEditParams))
-> IO
     (Either ResponseError Value,
      Maybe (ServerMethod, ApplyWorkspaceEditParams))
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> Either ResponseError Value
forall a b. b -> Either a b
Right Value
J.Null, Maybe (ServerMethod, ApplyWorkspaceEditParams)
forall a. Maybe a
Nothing)
              -- Couldn't parse the fallback command params
              -- _ -> liftIO $
              --   LSP.sendErrorResponseS (LSP.sendFunc lf)
              --                           (J.responseId (req ^. J.id))
              --                           J.InvalidParams
              --                           "Invalid fallbackCodeAction params"

          -- Just an ordinary HIE command
          Just (PluginId
plugin, CommandId
cmd) -> Map PluginId [PluginCommand]
-> LspFuncs Config
-> IdeState
-> PluginId
-> CommandId
-> Value
-> IO
     (Either ResponseError Value,
      Maybe (ServerMethod, ApplyWorkspaceEditParams))
runPluginCommand Map PluginId [PluginCommand]
pluginMap LspFuncs Config
lf IdeState
ide PluginId
plugin CommandId
cmd Value
cmdParams

          -- Couldn't parse the command identifier
          Maybe (PluginId, CommandId)
_ -> (Either ResponseError Value,
 Maybe (ServerMethod, ApplyWorkspaceEditParams))
-> IO
     (Either ResponseError Value,
      Maybe (ServerMethod, ApplyWorkspaceEditParams))
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
InvalidParams Text
"Invalid command identifier" Maybe Value
forall a. Maybe a
Nothing, Maybe (ServerMethod, ApplyWorkspaceEditParams)
forall a. Maybe a
Nothing)

  ExecuteCommandParams
-> IO
     (Either ResponseError Value,
      Maybe (ServerMethod, ApplyWorkspaceEditParams))
execCmd

{-
       ReqExecuteCommand req -> do
          liftIO $ U.logs $ "reactor:got ExecuteCommandRequest:" ++ show req
          lf <- asks lspFuncs

          let params = req ^. J.params

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

              callback obj = do
                liftIO $ U.logs $ "ExecuteCommand response got:r=" ++ show obj
                case fromDynJSON obj :: Maybe J.WorkspaceEdit of
                  Just v -> do
                    lid <- nextLspReqId
                    reactorSend $ RspExecuteCommand $ Core.makeResponseMessage req (A.Object mempty)
                    let msg = fmServerApplyWorkspaceEditRequest lid $ J.ApplyWorkspaceEditParams v
                    liftIO $ U.logs $ "ExecuteCommand sending edit: " ++ show msg
                    reactorSend $ ReqApplyWorkspaceEdit msg
                  Nothing -> reactorSend $ RspExecuteCommand $ Core.makeResponseMessage req $ dynToJSON obj

              execCmd cmdId args = do
                -- The parameters to the HIE command are always the first element
                let cmdParams = case args of
                     Just (J.List (x:_)) -> x
                     _ -> A.Null

                case parseCmdId cmdId of
                  -- Shortcut for immediately applying a applyWorkspaceEdit as a fallback for v3.8 code actions
                  Just ("hls", "fallbackCodeAction") -> do
                    case A.fromJSON cmdParams of
                      A.Success (FallbackCodeActionParams mEdit mCmd) -> do

                        -- Send off the workspace request if it has one
                        forM_ mEdit $ \edit -> do
                          lid <- nextLspReqId
                          let eParams = J.ApplyWorkspaceEditParams edit
                              eReq = fmServerApplyWorkspaceEditRequest lid eParams
                          reactorSend $ ReqApplyWorkspaceEdit eReq

                        case mCmd of
                          -- If we have a command, continue to execute it
                          Just (J.Command _ innerCmdId innerArgs) -> execCmd innerCmdId innerArgs

                          -- Otherwise we need to send back a response oureslves
                          Nothing -> reactorSend $ RspExecuteCommand $ Core.makeResponseMessage req (A.Object mempty)

                      -- Couldn't parse the fallback command params
                      _ -> liftIO $
                        Core.sendErrorResponseS (Core.sendFunc lf)
                                                (J.responseId (req ^. J.id))
                                                J.InvalidParams
                                                "Invalid fallbackCodeAction params"
                  -- Just an ordinary HIE command
                  Just (plugin, cmd) ->
                    let preq = GReq tn "plugin" Nothing Nothing (Just $ req ^. J.id) callback (toDynJSON (Nothing :: Maybe J.WorkspaceEdit))
                               $ runPluginCommand plugin cmd cmdParams
                    in makeRequest preq

                  -- Couldn't parse the command identifier
                  _ -> liftIO $
                    Core.sendErrorResponseS (Core.sendFunc lf)
                                            (J.responseId (req ^. J.id))
                                            J.InvalidParams
                                            "Invalid command identifier"

          execCmd (params ^. J.command) (params ^. J.arguments)
-}

-- -----------------------------------------------------------
wrapUnhandledExceptions ::
    (a -> IO (Either ResponseError J.Value, Maybe b)) ->
       a -> IO (Either ResponseError J.Value, Maybe b)
wrapUnhandledExceptions :: (a -> IO (Either ResponseError Value, Maybe b))
-> a -> IO (Either ResponseError Value, Maybe b)
wrapUnhandledExceptions a -> IO (Either ResponseError Value, Maybe b)
action a
input =
    IO (Either ResponseError Value, Maybe b)
-> (SomeException -> IO (Either ResponseError Value, Maybe b))
-> IO (Either ResponseError Value, Maybe b)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (a -> IO (Either ResponseError Value, Maybe b)
action a
input) ((SomeException -> IO (Either ResponseError Value, Maybe b))
 -> IO (Either ResponseError Value, Maybe b))
-> (SomeException -> IO (Either ResponseError Value, Maybe b))
-> IO (Either ResponseError Value, Maybe b)
forall a b. (a -> b) -> a -> b
$ \(SomeException
e::SomeException) -> do
        let resp :: ResponseError
resp = ErrorCode -> Text -> Maybe Value -> ResponseError
ResponseError ErrorCode
InternalError (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall a. Show a => a -> String
show SomeException
e) Maybe Value
forall a. Maybe a
Nothing
        (Either ResponseError Value, Maybe b)
-> IO (Either ResponseError Value, Maybe b)
forall (m :: * -> *) a. Monad m => a -> m a
return (ResponseError -> Either ResponseError Value
forall a b. a -> Either a b
Left ResponseError
resp, Maybe b
forall a. Maybe a
Nothing)


-- | Runs a plugin command given a PluginId, CommandId and
-- arguments in the form of a JSON object.
runPluginCommand :: Map.Map PluginId [PluginCommand]
                 -> LSP.LspFuncs Config
                 -> IdeState
                 -> PluginId
                 -> CommandId
                 -> J.Value
                 -> IO (Either ResponseError J.Value,
                        Maybe (ServerMethod, ApplyWorkspaceEditParams))
runPluginCommand :: Map PluginId [PluginCommand]
-> LspFuncs Config
-> IdeState
-> PluginId
-> CommandId
-> Value
-> IO
     (Either ResponseError Value,
      Maybe (ServerMethod, ApplyWorkspaceEditParams))
runPluginCommand Map PluginId [PluginCommand]
m LspFuncs Config
lf IdeState
ide  p :: PluginId
p@(PluginId Text
p') com :: CommandId
com@(CommandId Text
com') Value
arg =
  case PluginId -> Map PluginId [PluginCommand] -> Maybe [PluginCommand]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PluginId
p Map PluginId [PluginCommand]
m of
    Maybe [PluginCommand]
Nothing -> (Either ResponseError Value,
 Maybe (ServerMethod, ApplyWorkspaceEditParams))
-> IO
     (Either ResponseError Value,
      Maybe (ServerMethod, ApplyWorkspaceEditParams))
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, Maybe (ServerMethod, ApplyWorkspaceEditParams)
forall a. Maybe a
Nothing)
    Just [PluginCommand]
xs -> case (PluginCommand -> Bool) -> [PluginCommand] -> Maybe PluginCommand
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 -> CommandId) -> PluginCommand -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PluginCommand -> CommandId
commandId) [PluginCommand]
xs of
      Maybe PluginCommand
Nothing -> (Either ResponseError Value,
 Maybe (ServerMethod, ApplyWorkspaceEditParams))
-> IO
     (Either ResponseError Value,
      Maybe (ServerMethod, ApplyWorkspaceEditParams))
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
"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 -> CommandId) -> [PluginCommand] -> [CommandId]
forall a b. (a -> b) -> [a] -> [b]
map PluginCommand -> CommandId
commandId [PluginCommand]
xs)) Maybe Value
forall a. Maybe a
Nothing, Maybe (ServerMethod, ApplyWorkspaceEditParams)
forall a. Maybe a
Nothing)
      Just (PluginCommand CommandId
_ Text
_ CommandFunction 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,
 Maybe (ServerMethod, ApplyWorkspaceEditParams))
-> IO
     (Either ResponseError Value,
      Maybe (ServerMethod, ApplyWorkspaceEditParams))
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
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, Maybe (ServerMethod, ApplyWorkspaceEditParams)
forall a. Maybe a
Nothing)
        J.Success a
a -> CommandFunction a
f LspFuncs Config
lf IdeState
ide a
a

-- lsp-request: error while parsing args for typesignature.add in plugin ghcide:
-- When parsing the record ExecuteCommandParams of type
-- Language.Haskell.LSP.Types.DataTypesJSON.ExecuteCommandParams the key command
-- was not present.

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

mkLspCommand :: PluginId -> CommandId -> T.Text -> Maybe [J.Value] -> IO Command
mkLspCommand :: PluginId -> CommandId -> Text -> Maybe [Value] -> IO Command
mkLspCommand PluginId
plid CommandId
cn Text
title Maybe [Value]
args' = do
  Text
pid <- IO Text
getPid
  let cmdId :: Text
cmdId = Text -> PluginId -> CommandId -> Text
mkLspCmdId Text
pid PluginId
plid CommandId
cn
  let args :: Maybe (List Value)
args = [Value] -> List Value
forall a. [a] -> List a
List ([Value] -> List Value) -> Maybe [Value] -> Maybe (List Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [Value]
args'
  Command -> IO Command
forall (m :: * -> *) a. Monad m => a -> m a
return (Command -> IO Command) -> Command -> IO Command
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Maybe (List Value) -> Command
Command Text
title Text
cmdId Maybe (List Value)
args

mkLspCmdId :: T.Text -> PluginId -> CommandId -> T.Text
mkLspCmdId :: Text -> PluginId -> CommandId -> Text
mkLspCmdId Text
pid (PluginId Text
plid) (CommandId Text
cid)
  = Text
pid Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
plid Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
cid

allLspCmdIds :: T.Text -> [(PluginId, [PluginCommand])] -> [T.Text]
allLspCmdIds :: Text -> [(PluginId, [PluginCommand])] -> [Text]
allLspCmdIds Text
pid [(PluginId, [PluginCommand])]
commands = [[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Text]] -> [Text]) -> [[Text]] -> [Text]
forall a b. (a -> b) -> a -> b
$ ((PluginId, [PluginCommand]) -> [Text])
-> [(PluginId, [PluginCommand])] -> [[Text]]
forall a b. (a -> b) -> [a] -> [b]
map (PluginId, [PluginCommand]) -> [Text]
go [(PluginId, [PluginCommand])]
commands
  where
    go :: (PluginId, [PluginCommand]) -> [Text]
go (PluginId
plid, [PluginCommand]
cmds) = (PluginCommand -> Text) -> [PluginCommand] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> PluginId -> CommandId -> Text
mkLspCmdId Text
pid PluginId
plid (CommandId -> Text)
-> (PluginCommand -> CommandId) -> PluginCommand -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PluginCommand -> CommandId
commandId) [PluginCommand]
cmds

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

hoverPlugins :: [(PluginId, HoverProvider)] -> Plugin Config
hoverPlugins :: [(PluginId, HoverProvider)] -> Plugin Config
hoverPlugins [(PluginId, HoverProvider)]
hs = Rules () -> PartialHandlers Config -> Plugin Config
forall c. Rules () -> PartialHandlers c -> Plugin c
Plugin Rules ()
hoverRules ([(PluginId, HoverProvider)] -> PartialHandlers Config
hoverHandlers [(PluginId, HoverProvider)]
hs)

hoverRules :: Rules ()
hoverRules :: Rules ()
hoverRules = Rules ()
forall a. Monoid a => a
mempty

hoverHandlers :: [(PluginId, HoverProvider)] -> PartialHandlers Config
hoverHandlers :: [(PluginId, HoverProvider)] -> PartialHandlers Config
hoverHandlers [(PluginId, HoverProvider)]
hps = (WithMessage Config -> Handlers -> IO Handlers)
-> PartialHandlers Config
forall c.
(WithMessage c -> Handlers -> IO Handlers) -> PartialHandlers c
PartialHandlers ((WithMessage Config -> Handlers -> IO Handlers)
 -> PartialHandlers Config)
-> (WithMessage Config -> Handlers -> IO Handlers)
-> PartialHandlers Config
forall a b. (a -> b) -> a -> b
$ \WithMessage{(LspFuncs Config -> IdeState -> InitializeParams -> IO ())
-> Maybe (Handler InitializeRequest)
forall m req.
(Show m, Show req) =>
Maybe (Handler (NotificationMessage m req))
-> (LspFuncs Config -> IdeState -> req -> IO ())
-> Maybe (Handler (NotificationMessage m req))
forall m req resp.
(Show m, Show req) =>
(ResponseMessage resp -> FromServerMessage)
-> (LspFuncs Config
    -> IdeState -> req -> IO (Either ResponseError resp))
-> Maybe (Handler (RequestMessage m req resp))
forall m rm req resp newReqParams newReqBody.
(Show m, Show rm, Show req, Show newReqParams, Show newReqBody) =>
(ResponseMessage resp -> FromServerMessage)
-> (RequestMessage rm newReqParams newReqBody -> FromServerMessage)
-> (LspFuncs Config
    -> IdeState
    -> req
    -> IO (Either ResponseError resp, Maybe (rm, newReqParams)))
-> Maybe (Handler (RequestMessage m req resp))
withInitialize :: (LspFuncs Config -> IdeState -> InitializeParams -> IO ())
-> Maybe (Handler InitializeRequest)
withResponseAndRequest :: forall m rm req resp newReqParams newReqBody.
(Show m, Show rm, Show req, Show newReqParams, Show newReqBody) =>
(ResponseMessage resp -> FromServerMessage)
-> (RequestMessage rm newReqParams newReqBody -> FromServerMessage)
-> (LspFuncs Config
    -> IdeState
    -> req
    -> IO (Either ResponseError resp, Maybe (rm, newReqParams)))
-> Maybe (Handler (RequestMessage m req resp))
withNotification :: forall m req.
(Show m, Show req) =>
Maybe (Handler (NotificationMessage m req))
-> (LspFuncs Config -> IdeState -> req -> IO ())
-> Maybe (Handler (NotificationMessage m req))
withResponse :: forall m req resp.
(Show m, Show req) =>
(ResponseMessage resp -> FromServerMessage)
-> (LspFuncs Config
    -> IdeState -> req -> IO (Either ResponseError resp))
-> Maybe (Handler (RequestMessage m req resp))
$sel:withResponse:WithMessage :: forall c.
WithMessage c
-> forall m req resp.
   (Show m, Show req) =>
   (ResponseMessage resp -> FromServerMessage)
   -> (LspFuncs c
       -> IdeState -> req -> IO (Either ResponseError resp))
   -> Maybe (Handler (RequestMessage m req resp))
$sel:withNotification:WithMessage :: forall c.
WithMessage c
-> forall m req.
   (Show m, Show req) =>
   Maybe (Handler (NotificationMessage m req))
   -> (LspFuncs c -> IdeState -> req -> IO ())
   -> Maybe (Handler (NotificationMessage m req))
$sel:withResponseAndRequest:WithMessage :: forall c.
WithMessage c
-> forall m rm req resp newReqParams newReqBody.
   (Show m, Show rm, Show req, Show newReqParams, Show newReqBody) =>
   (ResponseMessage resp -> FromServerMessage)
   -> (RequestMessage rm newReqParams newReqBody -> FromServerMessage)
   -> (LspFuncs c
       -> IdeState
       -> req
       -> IO (Either ResponseError resp, Maybe (rm, newReqParams)))
   -> Maybe (Handler (RequestMessage m req resp))
$sel:withInitialize:WithMessage :: forall c.
WithMessage c
-> (LspFuncs c -> IdeState -> InitializeParams -> IO ())
-> Maybe (Handler InitializeRequest)
..} Handlers
x ->
  Handlers -> IO Handlers
forall (m :: * -> *) a. Monad m => a -> m a
return Handlers
x{hoverHandler :: Maybe (Handler HoverRequest)
LSP.hoverHandler = (ResponseMessage (Maybe Hover) -> FromServerMessage)
-> (LspFuncs Config -> HoverProvider)
-> Maybe (Handler HoverRequest)
forall m req resp.
(Show m, Show req) =>
(ResponseMessage resp -> FromServerMessage)
-> (LspFuncs Config
    -> IdeState -> req -> IO (Either ResponseError resp))
-> Maybe (Handler (RequestMessage m req resp))
withResponse ResponseMessage (Maybe Hover) -> FromServerMessage
RspHover ([(PluginId, HoverProvider)] -> LspFuncs Config -> HoverProvider
makeHover [(PluginId, HoverProvider)]
hps)}

makeHover :: [(PluginId, HoverProvider)]
      -> LSP.LspFuncs Config -> IdeState
      -> TextDocumentPositionParams
      -> IO (Either ResponseError (Maybe Hover))
makeHover :: [(PluginId, HoverProvider)] -> LspFuncs Config -> HoverProvider
makeHover [(PluginId, HoverProvider)]
hps LspFuncs Config
_lf IdeState
ideState TextDocumentPositionParams
params
  = do
      [Either ResponseError (Maybe Hover)]
mhs <- ((PluginId, HoverProvider)
 -> IO (Either ResponseError (Maybe Hover)))
-> [(PluginId, HoverProvider)]
-> IO [Either ResponseError (Maybe Hover)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(PluginId
_,HoverProvider
p) -> HoverProvider
p IdeState
ideState TextDocumentPositionParams
params) [(PluginId, HoverProvider)]
hps
      -- TODO: We should support ServerCapabilities and declare that
      -- we don't support hover requests during initialization if we
      -- don't have any hover providers
      -- TODO: maybe only have provider give MarkedString and
      -- work out range here?
      let hs :: [Hover]
hs = [Maybe Hover] -> [Hover]
forall a. [Maybe a] -> [a]
catMaybes ([Either ResponseError (Maybe Hover)] -> [Maybe Hover]
forall a b. [Either a b] -> [b]
rights [Either ResponseError (Maybe Hover)]
mhs)
          r :: Maybe Range
r = [Range] -> Maybe Range
forall a. [a] -> Maybe a
listToMaybe ([Range] -> Maybe Range) -> [Range] -> Maybe Range
forall a b. (a -> b) -> a -> b
$ (Hover -> Maybe Range) -> [Hover] -> [Range]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Hover -> Getting (Maybe Range) Hover (Maybe Range) -> Maybe Range
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Range) Hover (Maybe Range)
forall s a. HasRange s a => Lens' s a
range) [Hover]
hs
          h :: Maybe Hover
h = case [HoverContents] -> HoverContents
forall a. Monoid a => [a] -> a
mconcat (((Hover -> HoverContents) -> [Hover] -> [HoverContents]
forall a b. (a -> b) -> [a] -> [b]
map (Hover -> Getting HoverContents Hover HoverContents -> HoverContents
forall s a. s -> Getting a s a -> a
^. Getting HoverContents Hover HoverContents
forall s a. HasContents s a => Lens' s a
contents) [Hover]
hs) :: [HoverContents]) of
            HoverContentsMS (List []) -> Maybe Hover
forall a. Maybe a
Nothing
            HoverContents
hh                        -> Hover -> Maybe Hover
forall a. a -> Maybe a
Just (Hover -> Maybe Hover) -> Hover -> Maybe Hover
forall a b. (a -> b) -> a -> b
$ HoverContents -> Maybe Range -> Hover
Hover HoverContents
hh Maybe Range
r
      Either ResponseError (Maybe Hover)
-> IO (Either ResponseError (Maybe Hover))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ResponseError (Maybe Hover)
 -> IO (Either ResponseError (Maybe Hover)))
-> Either ResponseError (Maybe Hover)
-> IO (Either ResponseError (Maybe Hover))
forall a b. (a -> b) -> a -> b
$ Maybe Hover -> Either ResponseError (Maybe Hover)
forall a b. b -> Either a b
Right Maybe Hover
h

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

symbolsPlugins :: [(PluginId, SymbolsProvider)] -> Plugin Config
symbolsPlugins :: [(PluginId, SymbolsProvider)] -> Plugin Config
symbolsPlugins [(PluginId, SymbolsProvider)]
hs = Rules () -> PartialHandlers Config -> Plugin Config
forall c. Rules () -> PartialHandlers c -> Plugin c
Plugin Rules ()
symbolsRules ([(PluginId, SymbolsProvider)] -> PartialHandlers Config
symbolsHandlers [(PluginId, SymbolsProvider)]
hs)

symbolsRules :: Rules ()
symbolsRules :: Rules ()
symbolsRules = Rules ()
forall a. Monoid a => a
mempty

symbolsHandlers :: [(PluginId, SymbolsProvider)] -> PartialHandlers Config
symbolsHandlers :: [(PluginId, SymbolsProvider)] -> PartialHandlers Config
symbolsHandlers [(PluginId, SymbolsProvider)]
hps = (WithMessage Config -> Handlers -> IO Handlers)
-> PartialHandlers Config
forall c.
(WithMessage c -> Handlers -> IO Handlers) -> PartialHandlers c
PartialHandlers ((WithMessage Config -> Handlers -> IO Handlers)
 -> PartialHandlers Config)
-> (WithMessage Config -> Handlers -> IO Handlers)
-> PartialHandlers Config
forall a b. (a -> b) -> a -> b
$ \WithMessage{(LspFuncs Config -> IdeState -> InitializeParams -> IO ())
-> Maybe (Handler InitializeRequest)
forall m req.
(Show m, Show req) =>
Maybe (Handler (NotificationMessage m req))
-> (LspFuncs Config -> IdeState -> req -> IO ())
-> Maybe (Handler (NotificationMessage m req))
forall m req resp.
(Show m, Show req) =>
(ResponseMessage resp -> FromServerMessage)
-> (LspFuncs Config
    -> IdeState -> req -> IO (Either ResponseError resp))
-> Maybe (Handler (RequestMessage m req resp))
forall m rm req resp newReqParams newReqBody.
(Show m, Show rm, Show req, Show newReqParams, Show newReqBody) =>
(ResponseMessage resp -> FromServerMessage)
-> (RequestMessage rm newReqParams newReqBody -> FromServerMessage)
-> (LspFuncs Config
    -> IdeState
    -> req
    -> IO (Either ResponseError resp, Maybe (rm, newReqParams)))
-> Maybe (Handler (RequestMessage m req resp))
withInitialize :: (LspFuncs Config -> IdeState -> InitializeParams -> IO ())
-> Maybe (Handler InitializeRequest)
withResponseAndRequest :: forall m rm req resp newReqParams newReqBody.
(Show m, Show rm, Show req, Show newReqParams, Show newReqBody) =>
(ResponseMessage resp -> FromServerMessage)
-> (RequestMessage rm newReqParams newReqBody -> FromServerMessage)
-> (LspFuncs Config
    -> IdeState
    -> req
    -> IO (Either ResponseError resp, Maybe (rm, newReqParams)))
-> Maybe (Handler (RequestMessage m req resp))
withNotification :: forall m req.
(Show m, Show req) =>
Maybe (Handler (NotificationMessage m req))
-> (LspFuncs Config -> IdeState -> req -> IO ())
-> Maybe (Handler (NotificationMessage m req))
withResponse :: forall m req resp.
(Show m, Show req) =>
(ResponseMessage resp -> FromServerMessage)
-> (LspFuncs Config
    -> IdeState -> req -> IO (Either ResponseError resp))
-> Maybe (Handler (RequestMessage m req resp))
$sel:withResponse:WithMessage :: forall c.
WithMessage c
-> forall m req resp.
   (Show m, Show req) =>
   (ResponseMessage resp -> FromServerMessage)
   -> (LspFuncs c
       -> IdeState -> req -> IO (Either ResponseError resp))
   -> Maybe (Handler (RequestMessage m req resp))
$sel:withNotification:WithMessage :: forall c.
WithMessage c
-> forall m req.
   (Show m, Show req) =>
   Maybe (Handler (NotificationMessage m req))
   -> (LspFuncs c -> IdeState -> req -> IO ())
   -> Maybe (Handler (NotificationMessage m req))
$sel:withResponseAndRequest:WithMessage :: forall c.
WithMessage c
-> forall m rm req resp newReqParams newReqBody.
   (Show m, Show rm, Show req, Show newReqParams, Show newReqBody) =>
   (ResponseMessage resp -> FromServerMessage)
   -> (RequestMessage rm newReqParams newReqBody -> FromServerMessage)
   -> (LspFuncs c
       -> IdeState
       -> req
       -> IO (Either ResponseError resp, Maybe (rm, newReqParams)))
   -> Maybe (Handler (RequestMessage m req resp))
$sel:withInitialize:WithMessage :: forall c.
WithMessage c
-> (LspFuncs c -> IdeState -> InitializeParams -> IO ())
-> Maybe (Handler InitializeRequest)
..} Handlers
x ->
  Handlers -> IO Handlers
forall (m :: * -> *) a. Monad m => a -> m a
return Handlers
x {documentSymbolHandler :: Maybe (Handler DocumentSymbolRequest)
LSP.documentSymbolHandler = (ResponseMessage DSResult -> FromServerMessage)
-> (LspFuncs Config
    -> IdeState
    -> DocumentSymbolParams
    -> IO (Either ResponseError DSResult))
-> Maybe (Handler DocumentSymbolRequest)
forall m req resp.
(Show m, Show req) =>
(ResponseMessage resp -> FromServerMessage)
-> (LspFuncs Config
    -> IdeState -> req -> IO (Either ResponseError resp))
-> Maybe (Handler (RequestMessage m req resp))
withResponse ResponseMessage DSResult -> FromServerMessage
RspDocumentSymbols ([(PluginId, SymbolsProvider)]
-> LspFuncs Config
-> IdeState
-> DocumentSymbolParams
-> IO (Either ResponseError DSResult)
makeSymbols [(PluginId, SymbolsProvider)]
hps)}

makeSymbols :: [(PluginId, SymbolsProvider)]
      -> LSP.LspFuncs Config
      -> IdeState
      -> DocumentSymbolParams
      -> IO (Either ResponseError DSResult)
makeSymbols :: [(PluginId, SymbolsProvider)]
-> LspFuncs Config
-> IdeState
-> DocumentSymbolParams
-> IO (Either ResponseError DSResult)
makeSymbols [(PluginId, SymbolsProvider)]
sps LspFuncs Config
lf IdeState
ideState DocumentSymbolParams
params
  = do
      let uri' :: Uri
uri' = DocumentSymbolParams
params DocumentSymbolParams -> Getting Uri DocumentSymbolParams Uri -> Uri
forall s a. s -> Getting a s a -> a
^. (TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> DocumentSymbolParams -> Const Uri DocumentSymbolParams
forall s a. HasTextDocument s a => Lens' s a
textDocument ((TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
 -> DocumentSymbolParams -> Const Uri DocumentSymbolParams)
-> ((Uri -> Const Uri Uri)
    -> TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> Getting Uri DocumentSymbolParams Uri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Uri -> Const Uri Uri)
-> TextDocumentIdentifier -> Const Uri TextDocumentIdentifier
forall s a. HasUri s a => Lens' s a
uri
          (C.ClientCapabilities Maybe WorkspaceClientCapabilities
_ Maybe TextDocumentClientCapabilities
tdc Maybe WindowClientCapabilities
_ Maybe Object
_) = LspFuncs Config -> ClientCapabilities
forall c. LspFuncs c -> ClientCapabilities
LSP.clientCapabilities LspFuncs Config
lf
          supportsHierarchy :: Bool
supportsHierarchy = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Maybe TextDocumentClientCapabilities
tdc Maybe TextDocumentClientCapabilities
-> (TextDocumentClientCapabilities
    -> Maybe DocumentSymbolClientCapabilities)
-> Maybe DocumentSymbolClientCapabilities
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TextDocumentClientCapabilities
-> Maybe DocumentSymbolClientCapabilities
C._documentSymbol
                              Maybe DocumentSymbolClientCapabilities
-> (DocumentSymbolClientCapabilities -> Maybe Bool) -> Maybe Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= DocumentSymbolClientCapabilities -> Maybe Bool
C._hierarchicalDocumentSymbolSupport
          convertSymbols :: [DocumentSymbol] -> DSResult
          convertSymbols :: [DocumentSymbol] -> DSResult
convertSymbols [DocumentSymbol]
symbs
            | Bool
supportsHierarchy = List DocumentSymbol -> DSResult
DSDocumentSymbols (List DocumentSymbol -> DSResult)
-> List DocumentSymbol -> DSResult
forall a b. (a -> b) -> a -> b
$ [DocumentSymbol] -> List DocumentSymbol
forall a. [a] -> List a
List [DocumentSymbol]
symbs
            | Bool
otherwise = List SymbolInformation -> DSResult
DSSymbolInformation ([SymbolInformation] -> List SymbolInformation
forall a. [a] -> List a
List ([SymbolInformation] -> List SymbolInformation)
-> [SymbolInformation] -> List SymbolInformation
forall a b. (a -> b) -> a -> b
$ (DocumentSymbol -> [SymbolInformation])
-> [DocumentSymbol] -> [SymbolInformation]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Maybe Text -> DocumentSymbol -> [SymbolInformation]
go Maybe Text
forall a. Maybe a
Nothing) [DocumentSymbol]
symbs)
            where
                go :: Maybe T.Text -> DocumentSymbol -> [SymbolInformation]
                go :: Maybe Text -> DocumentSymbol -> [SymbolInformation]
go Maybe Text
parent DocumentSymbol
ds =
                  let children' :: [SymbolInformation]
                      children' :: [SymbolInformation]
children' = (DocumentSymbol -> [SymbolInformation])
-> List DocumentSymbol -> [SymbolInformation]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Maybe Text -> DocumentSymbol -> [SymbolInformation]
go (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
name')) (List DocumentSymbol
-> Maybe (List DocumentSymbol) -> List DocumentSymbol
forall a. a -> Maybe a -> a
fromMaybe List DocumentSymbol
forall a. Monoid a => a
mempty (DocumentSymbol
ds DocumentSymbol
-> Getting
     (Maybe (List DocumentSymbol))
     DocumentSymbol
     (Maybe (List DocumentSymbol))
-> Maybe (List DocumentSymbol)
forall s a. s -> Getting a s a -> a
^. Getting
  (Maybe (List DocumentSymbol))
  DocumentSymbol
  (Maybe (List DocumentSymbol))
forall s a. HasChildren s a => Lens' s a
children))
                      loc :: Location
loc = Uri -> Range -> Location
Location Uri
uri' (DocumentSymbol
ds DocumentSymbol -> Getting Range DocumentSymbol Range -> Range
forall s a. s -> Getting a s a -> a
^. Getting Range DocumentSymbol Range
forall s a. HasRange s a => Lens' s a
range)
                      name' :: Text
name' = DocumentSymbol
ds DocumentSymbol -> Getting Text DocumentSymbol Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text DocumentSymbol Text
forall s a. HasName s a => Lens' s a
name
                      si :: SymbolInformation
si = Text
-> SymbolKind
-> Maybe Bool
-> Location
-> Maybe Text
-> SymbolInformation
SymbolInformation Text
name' (DocumentSymbol
ds DocumentSymbol
-> Getting SymbolKind DocumentSymbol SymbolKind -> SymbolKind
forall s a. s -> Getting a s a -> a
^. Getting SymbolKind DocumentSymbol SymbolKind
forall s a. HasKind s a => Lens' s a
kind) (DocumentSymbol
ds DocumentSymbol
-> Getting (Maybe Bool) DocumentSymbol (Maybe Bool) -> Maybe Bool
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Bool) DocumentSymbol (Maybe Bool)
forall s a. HasDeprecated s a => Lens' s a
deprecated) Location
loc Maybe Text
parent
                  in [SymbolInformation
si] [SymbolInformation] -> [SymbolInformation] -> [SymbolInformation]
forall a. Semigroup a => a -> a -> a
<> [SymbolInformation]
children'

      [Either ResponseError [DocumentSymbol]]
mhs <- ((PluginId, SymbolsProvider)
 -> IO (Either ResponseError [DocumentSymbol]))
-> [(PluginId, SymbolsProvider)]
-> IO [Either ResponseError [DocumentSymbol]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(PluginId
_,SymbolsProvider
p) -> SymbolsProvider
p LspFuncs Config
lf IdeState
ideState DocumentSymbolParams
params) [(PluginId, SymbolsProvider)]
sps
      case [Either ResponseError [DocumentSymbol]] -> [[DocumentSymbol]]
forall a b. [Either a b] -> [b]
rights [Either ResponseError [DocumentSymbol]]
mhs of
          [] -> Either ResponseError DSResult -> IO (Either ResponseError DSResult)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ResponseError DSResult
 -> IO (Either ResponseError DSResult))
-> Either ResponseError DSResult
-> IO (Either ResponseError DSResult)
forall a b. (a -> b) -> a -> b
$ ResponseError -> Either ResponseError DSResult
forall a b. a -> Either a b
Left (ResponseError -> Either ResponseError DSResult)
-> ResponseError -> Either ResponseError DSResult
forall a b. (a -> b) -> a -> b
$ Text -> ResponseError
responseError (Text -> ResponseError) -> Text -> ResponseError
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ [ResponseError] -> String
forall a. Show a => a -> String
show ([ResponseError] -> String) -> [ResponseError] -> String
forall a b. (a -> b) -> a -> b
$ [Either ResponseError [DocumentSymbol]] -> [ResponseError]
forall a b. [Either a b] -> [a]
lefts [Either ResponseError [DocumentSymbol]]
mhs
          [[DocumentSymbol]]
hs -> Either ResponseError DSResult -> IO (Either ResponseError DSResult)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ResponseError DSResult
 -> IO (Either ResponseError DSResult))
-> Either ResponseError DSResult
-> IO (Either ResponseError DSResult)
forall a b. (a -> b) -> a -> b
$ DSResult -> Either ResponseError DSResult
forall a b. b -> Either a b
Right (DSResult -> Either ResponseError DSResult)
-> DSResult -> Either ResponseError DSResult
forall a b. (a -> b) -> a -> b
$ [DocumentSymbol] -> DSResult
convertSymbols ([DocumentSymbol] -> DSResult) -> [DocumentSymbol] -> DSResult
forall a b. (a -> b) -> a -> b
$ [[DocumentSymbol]] -> [DocumentSymbol]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[DocumentSymbol]]
hs


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

renamePlugins :: [(PluginId, RenameProvider)] -> Plugin Config
renamePlugins :: [(PluginId, RenameProvider)] -> Plugin Config
renamePlugins [(PluginId, RenameProvider)]
providers = Rules () -> PartialHandlers Config -> Plugin Config
forall c. Rules () -> PartialHandlers c -> Plugin c
Plugin Rules ()
rules PartialHandlers Config
handlers
  where
    rules :: Rules ()
rules = Rules ()
forall a. Monoid a => a
mempty
    handlers :: PartialHandlers Config
handlers = (WithMessage Config -> Handlers -> IO Handlers)
-> PartialHandlers Config
forall c.
(WithMessage c -> Handlers -> IO Handlers) -> PartialHandlers c
PartialHandlers ((WithMessage Config -> Handlers -> IO Handlers)
 -> PartialHandlers Config)
-> (WithMessage Config -> Handlers -> IO Handlers)
-> PartialHandlers Config
forall a b. (a -> b) -> a -> b
$ \WithMessage{(LspFuncs Config -> IdeState -> InitializeParams -> IO ())
-> Maybe (Handler InitializeRequest)
forall m req.
(Show m, Show req) =>
Maybe (Handler (NotificationMessage m req))
-> (LspFuncs Config -> IdeState -> req -> IO ())
-> Maybe (Handler (NotificationMessage m req))
forall m req resp.
(Show m, Show req) =>
(ResponseMessage resp -> FromServerMessage)
-> (LspFuncs Config
    -> IdeState -> req -> IO (Either ResponseError resp))
-> Maybe (Handler (RequestMessage m req resp))
forall m rm req resp newReqParams newReqBody.
(Show m, Show rm, Show req, Show newReqParams, Show newReqBody) =>
(ResponseMessage resp -> FromServerMessage)
-> (RequestMessage rm newReqParams newReqBody -> FromServerMessage)
-> (LspFuncs Config
    -> IdeState
    -> req
    -> IO (Either ResponseError resp, Maybe (rm, newReqParams)))
-> Maybe (Handler (RequestMessage m req resp))
withInitialize :: (LspFuncs Config -> IdeState -> InitializeParams -> IO ())
-> Maybe (Handler InitializeRequest)
withResponseAndRequest :: forall m rm req resp newReqParams newReqBody.
(Show m, Show rm, Show req, Show newReqParams, Show newReqBody) =>
(ResponseMessage resp -> FromServerMessage)
-> (RequestMessage rm newReqParams newReqBody -> FromServerMessage)
-> (LspFuncs Config
    -> IdeState
    -> req
    -> IO (Either ResponseError resp, Maybe (rm, newReqParams)))
-> Maybe (Handler (RequestMessage m req resp))
withNotification :: forall m req.
(Show m, Show req) =>
Maybe (Handler (NotificationMessage m req))
-> (LspFuncs Config -> IdeState -> req -> IO ())
-> Maybe (Handler (NotificationMessage m req))
withResponse :: forall m req resp.
(Show m, Show req) =>
(ResponseMessage resp -> FromServerMessage)
-> (LspFuncs Config
    -> IdeState -> req -> IO (Either ResponseError resp))
-> Maybe (Handler (RequestMessage m req resp))
$sel:withResponse:WithMessage :: forall c.
WithMessage c
-> forall m req resp.
   (Show m, Show req) =>
   (ResponseMessage resp -> FromServerMessage)
   -> (LspFuncs c
       -> IdeState -> req -> IO (Either ResponseError resp))
   -> Maybe (Handler (RequestMessage m req resp))
$sel:withNotification:WithMessage :: forall c.
WithMessage c
-> forall m req.
   (Show m, Show req) =>
   Maybe (Handler (NotificationMessage m req))
   -> (LspFuncs c -> IdeState -> req -> IO ())
   -> Maybe (Handler (NotificationMessage m req))
$sel:withResponseAndRequest:WithMessage :: forall c.
WithMessage c
-> forall m rm req resp newReqParams newReqBody.
   (Show m, Show rm, Show req, Show newReqParams, Show newReqBody) =>
   (ResponseMessage resp -> FromServerMessage)
   -> (RequestMessage rm newReqParams newReqBody -> FromServerMessage)
   -> (LspFuncs c
       -> IdeState
       -> req
       -> IO (Either ResponseError resp, Maybe (rm, newReqParams)))
   -> Maybe (Handler (RequestMessage m req resp))
$sel:withInitialize:WithMessage :: forall c.
WithMessage c
-> (LspFuncs c -> IdeState -> InitializeParams -> IO ())
-> Maybe (Handler InitializeRequest)
..} Handlers
x -> Handlers -> IO Handlers
forall (m :: * -> *) a. Monad m => a -> m a
return Handlers
x
      { renameHandler :: Maybe (Handler RenameRequest)
LSP.renameHandler = (ResponseMessage WorkspaceEdit -> FromServerMessage)
-> RenameProvider -> Maybe (Handler RenameRequest)
forall m req resp.
(Show m, Show req) =>
(ResponseMessage resp -> FromServerMessage)
-> (LspFuncs Config
    -> IdeState -> req -> IO (Either ResponseError resp))
-> Maybe (Handler (RequestMessage m req resp))
withResponse ResponseMessage WorkspaceEdit -> FromServerMessage
RspRename ([(PluginId, RenameProvider)] -> RenameProvider
renameWith [(PluginId, RenameProvider)]
providers)}

renameWith ::
  [(PluginId, RenameProvider)] ->
  LSP.LspFuncs Config ->
  IdeState ->
  RenameParams ->
  IO (Either ResponseError WorkspaceEdit)
renameWith :: [(PluginId, RenameProvider)] -> RenameProvider
renameWith [(PluginId, RenameProvider)]
providers LspFuncs Config
lspFuncs IdeState
state RenameParams
params = do
    [Either ResponseError WorkspaceEdit]
results <- ((PluginId, RenameProvider)
 -> IO (Either ResponseError WorkspaceEdit))
-> [(PluginId, RenameProvider)]
-> IO [Either ResponseError WorkspaceEdit]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(PluginId
_,RenameProvider
p) -> RenameProvider
p LspFuncs Config
lspFuncs IdeState
state RenameParams
params) [(PluginId, RenameProvider)]
providers
    case [Either ResponseError WorkspaceEdit]
-> ([ResponseError], [WorkspaceEdit])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either ResponseError WorkspaceEdit]
results of
        ([ResponseError]
errors, []) -> Either ResponseError WorkspaceEdit
-> IO (Either ResponseError WorkspaceEdit)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ResponseError WorkspaceEdit
 -> IO (Either ResponseError WorkspaceEdit))
-> Either ResponseError WorkspaceEdit
-> IO (Either ResponseError WorkspaceEdit)
forall a b. (a -> b) -> a -> b
$ ResponseError -> Either ResponseError WorkspaceEdit
forall a b. a -> Either a b
Left (ResponseError -> Either ResponseError WorkspaceEdit)
-> ResponseError -> Either ResponseError WorkspaceEdit
forall a b. (a -> b) -> a -> b
$ Text -> ResponseError
responseError (Text -> ResponseError) -> Text -> ResponseError
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ [ResponseError] -> String
forall a. Show a => a -> String
show ([ResponseError] -> String) -> [ResponseError] -> String
forall a b. (a -> b) -> a -> b
$ [ResponseError]
errors
        ([ResponseError]
_, [WorkspaceEdit]
edits) -> Either ResponseError WorkspaceEdit
-> IO (Either ResponseError WorkspaceEdit)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ResponseError WorkspaceEdit
 -> IO (Either ResponseError WorkspaceEdit))
-> Either ResponseError WorkspaceEdit
-> IO (Either ResponseError WorkspaceEdit)
forall a b. (a -> b) -> a -> b
$ WorkspaceEdit -> Either ResponseError WorkspaceEdit
forall a b. b -> Either a b
Right (WorkspaceEdit -> Either ResponseError WorkspaceEdit)
-> WorkspaceEdit -> Either ResponseError WorkspaceEdit
forall a b. (a -> b) -> a -> b
$ [WorkspaceEdit] -> WorkspaceEdit
forall a. Monoid a => [a] -> a
mconcat [WorkspaceEdit]
edits

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

formatterPlugins :: [(PluginId, FormattingProvider IO)] -> Plugin Config
formatterPlugins :: [(PluginId, FormattingProvider IO)] -> Plugin Config
formatterPlugins [(PluginId, FormattingProvider IO)]
providers
    = Rules () -> PartialHandlers Config -> Plugin Config
forall c. Rules () -> PartialHandlers c -> Plugin c
Plugin Rules ()
formatterRules
             (Map PluginId (FormattingProvider IO) -> PartialHandlers Config
formatterHandlers ([(PluginId, FormattingProvider IO)]
-> Map PluginId (FormattingProvider IO)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ((PluginId
"none",FormattingProvider IO
noneProvider)(PluginId, FormattingProvider IO)
-> [(PluginId, FormattingProvider IO)]
-> [(PluginId, FormattingProvider IO)]
forall a. a -> [a] -> [a]
:[(PluginId, FormattingProvider IO)]
providers)))

formatterRules :: Rules ()
formatterRules :: Rules ()
formatterRules = Rules ()
forall a. Monoid a => a
mempty

formatterHandlers :: Map.Map PluginId (FormattingProvider IO) -> PartialHandlers Config
formatterHandlers :: Map PluginId (FormattingProvider IO) -> PartialHandlers Config
formatterHandlers Map PluginId (FormattingProvider IO)
providers = (WithMessage Config -> Handlers -> IO Handlers)
-> PartialHandlers Config
forall c.
(WithMessage c -> Handlers -> IO Handlers) -> PartialHandlers c
PartialHandlers ((WithMessage Config -> Handlers -> IO Handlers)
 -> PartialHandlers Config)
-> (WithMessage Config -> Handlers -> IO Handlers)
-> PartialHandlers Config
forall a b. (a -> b) -> a -> b
$ \WithMessage{(LspFuncs Config -> IdeState -> InitializeParams -> IO ())
-> Maybe (Handler InitializeRequest)
forall m req.
(Show m, Show req) =>
Maybe (Handler (NotificationMessage m req))
-> (LspFuncs Config -> IdeState -> req -> IO ())
-> Maybe (Handler (NotificationMessage m req))
forall m req resp.
(Show m, Show req) =>
(ResponseMessage resp -> FromServerMessage)
-> (LspFuncs Config
    -> IdeState -> req -> IO (Either ResponseError resp))
-> Maybe (Handler (RequestMessage m req resp))
forall m rm req resp newReqParams newReqBody.
(Show m, Show rm, Show req, Show newReqParams, Show newReqBody) =>
(ResponseMessage resp -> FromServerMessage)
-> (RequestMessage rm newReqParams newReqBody -> FromServerMessage)
-> (LspFuncs Config
    -> IdeState
    -> req
    -> IO (Either ResponseError resp, Maybe (rm, newReqParams)))
-> Maybe (Handler (RequestMessage m req resp))
withInitialize :: (LspFuncs Config -> IdeState -> InitializeParams -> IO ())
-> Maybe (Handler InitializeRequest)
withResponseAndRequest :: forall m rm req resp newReqParams newReqBody.
(Show m, Show rm, Show req, Show newReqParams, Show newReqBody) =>
(ResponseMessage resp -> FromServerMessage)
-> (RequestMessage rm newReqParams newReqBody -> FromServerMessage)
-> (LspFuncs Config
    -> IdeState
    -> req
    -> IO (Either ResponseError resp, Maybe (rm, newReqParams)))
-> Maybe (Handler (RequestMessage m req resp))
withNotification :: forall m req.
(Show m, Show req) =>
Maybe (Handler (NotificationMessage m req))
-> (LspFuncs Config -> IdeState -> req -> IO ())
-> Maybe (Handler (NotificationMessage m req))
withResponse :: forall m req resp.
(Show m, Show req) =>
(ResponseMessage resp -> FromServerMessage)
-> (LspFuncs Config
    -> IdeState -> req -> IO (Either ResponseError resp))
-> Maybe (Handler (RequestMessage m req resp))
$sel:withResponse:WithMessage :: forall c.
WithMessage c
-> forall m req resp.
   (Show m, Show req) =>
   (ResponseMessage resp -> FromServerMessage)
   -> (LspFuncs c
       -> IdeState -> req -> IO (Either ResponseError resp))
   -> Maybe (Handler (RequestMessage m req resp))
$sel:withNotification:WithMessage :: forall c.
WithMessage c
-> forall m req.
   (Show m, Show req) =>
   Maybe (Handler (NotificationMessage m req))
   -> (LspFuncs c -> IdeState -> req -> IO ())
   -> Maybe (Handler (NotificationMessage m req))
$sel:withResponseAndRequest:WithMessage :: forall c.
WithMessage c
-> forall m rm req resp newReqParams newReqBody.
   (Show m, Show rm, Show req, Show newReqParams, Show newReqBody) =>
   (ResponseMessage resp -> FromServerMessage)
   -> (RequestMessage rm newReqParams newReqBody -> FromServerMessage)
   -> (LspFuncs c
       -> IdeState
       -> req
       -> IO (Either ResponseError resp, Maybe (rm, newReqParams)))
   -> Maybe (Handler (RequestMessage m req resp))
$sel:withInitialize:WithMessage :: forall c.
WithMessage c
-> (LspFuncs c -> IdeState -> InitializeParams -> IO ())
-> Maybe (Handler InitializeRequest)
..} Handlers
x -> Handlers -> IO Handlers
forall (m :: * -> *) a. Monad m => a -> m a
return Handlers
x
    { documentFormattingHandler :: Maybe (Handler DocumentFormattingRequest)
LSP.documentFormattingHandler
        = (ResponseMessage (List TextEdit) -> FromServerMessage)
-> (LspFuncs Config
    -> IdeState
    -> DocumentFormattingParams
    -> IO (Either ResponseError (List TextEdit)))
-> Maybe (Handler DocumentFormattingRequest)
forall m req resp.
(Show m, Show req) =>
(ResponseMessage resp -> FromServerMessage)
-> (LspFuncs Config
    -> IdeState -> req -> IO (Either ResponseError resp))
-> Maybe (Handler (RequestMessage m req resp))
withResponse ResponseMessage (List TextEdit) -> FromServerMessage
RspDocumentFormatting (Map PluginId (FormattingProvider IO)
-> LspFuncs Config
-> IdeState
-> DocumentFormattingParams
-> IO (Either ResponseError (List TextEdit))
formatting Map PluginId (FormattingProvider IO)
providers)
    , documentRangeFormattingHandler :: Maybe (Handler DocumentRangeFormattingRequest)
LSP.documentRangeFormattingHandler
        = (ResponseMessage (List TextEdit) -> FromServerMessage)
-> (LspFuncs Config
    -> IdeState
    -> DocumentRangeFormattingParams
    -> IO (Either ResponseError (List TextEdit)))
-> Maybe (Handler DocumentRangeFormattingRequest)
forall m req resp.
(Show m, Show req) =>
(ResponseMessage resp -> FromServerMessage)
-> (LspFuncs Config
    -> IdeState -> req -> IO (Either ResponseError resp))
-> Maybe (Handler (RequestMessage m req resp))
withResponse ResponseMessage (List TextEdit) -> FromServerMessage
RspDocumentRangeFormatting (Map PluginId (FormattingProvider IO)
-> LspFuncs Config
-> IdeState
-> DocumentRangeFormattingParams
-> IO (Either ResponseError (List TextEdit))
rangeFormatting Map PluginId (FormattingProvider IO)
providers)
    }

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

completionsPlugins :: [(PluginId, CompletionProvider)] -> Plugin Config
completionsPlugins :: [(PluginId, CompletionProvider)] -> Plugin Config
completionsPlugins [(PluginId, CompletionProvider)]
cs = Rules () -> PartialHandlers Config -> Plugin Config
forall c. Rules () -> PartialHandlers c -> Plugin c
Plugin Rules ()
completionsRules ([(PluginId, CompletionProvider)] -> PartialHandlers Config
completionsHandlers [(PluginId, CompletionProvider)]
cs)

completionsRules :: Rules ()
completionsRules :: Rules ()
completionsRules = Rules ()
forall a. Monoid a => a
mempty

completionsHandlers :: [(PluginId, CompletionProvider)] -> PartialHandlers Config
completionsHandlers :: [(PluginId, CompletionProvider)] -> PartialHandlers Config
completionsHandlers [(PluginId, CompletionProvider)]
cps = (WithMessage Config -> Handlers -> IO Handlers)
-> PartialHandlers Config
forall c.
(WithMessage c -> Handlers -> IO Handlers) -> PartialHandlers c
PartialHandlers ((WithMessage Config -> Handlers -> IO Handlers)
 -> PartialHandlers Config)
-> (WithMessage Config -> Handlers -> IO Handlers)
-> PartialHandlers Config
forall a b. (a -> b) -> a -> b
$ \WithMessage{(LspFuncs Config -> IdeState -> InitializeParams -> IO ())
-> Maybe (Handler InitializeRequest)
forall m req.
(Show m, Show req) =>
Maybe (Handler (NotificationMessage m req))
-> (LspFuncs Config -> IdeState -> req -> IO ())
-> Maybe (Handler (NotificationMessage m req))
forall m req resp.
(Show m, Show req) =>
(ResponseMessage resp -> FromServerMessage)
-> (LspFuncs Config
    -> IdeState -> req -> IO (Either ResponseError resp))
-> Maybe (Handler (RequestMessage m req resp))
forall m rm req resp newReqParams newReqBody.
(Show m, Show rm, Show req, Show newReqParams, Show newReqBody) =>
(ResponseMessage resp -> FromServerMessage)
-> (RequestMessage rm newReqParams newReqBody -> FromServerMessage)
-> (LspFuncs Config
    -> IdeState
    -> req
    -> IO (Either ResponseError resp, Maybe (rm, newReqParams)))
-> Maybe (Handler (RequestMessage m req resp))
withInitialize :: (LspFuncs Config -> IdeState -> InitializeParams -> IO ())
-> Maybe (Handler InitializeRequest)
withResponseAndRequest :: forall m rm req resp newReqParams newReqBody.
(Show m, Show rm, Show req, Show newReqParams, Show newReqBody) =>
(ResponseMessage resp -> FromServerMessage)
-> (RequestMessage rm newReqParams newReqBody -> FromServerMessage)
-> (LspFuncs Config
    -> IdeState
    -> req
    -> IO (Either ResponseError resp, Maybe (rm, newReqParams)))
-> Maybe (Handler (RequestMessage m req resp))
withNotification :: forall m req.
(Show m, Show req) =>
Maybe (Handler (NotificationMessage m req))
-> (LspFuncs Config -> IdeState -> req -> IO ())
-> Maybe (Handler (NotificationMessage m req))
withResponse :: forall m req resp.
(Show m, Show req) =>
(ResponseMessage resp -> FromServerMessage)
-> (LspFuncs Config
    -> IdeState -> req -> IO (Either ResponseError resp))
-> Maybe (Handler (RequestMessage m req resp))
$sel:withResponse:WithMessage :: forall c.
WithMessage c
-> forall m req resp.
   (Show m, Show req) =>
   (ResponseMessage resp -> FromServerMessage)
   -> (LspFuncs c
       -> IdeState -> req -> IO (Either ResponseError resp))
   -> Maybe (Handler (RequestMessage m req resp))
$sel:withNotification:WithMessage :: forall c.
WithMessage c
-> forall m req.
   (Show m, Show req) =>
   Maybe (Handler (NotificationMessage m req))
   -> (LspFuncs c -> IdeState -> req -> IO ())
   -> Maybe (Handler (NotificationMessage m req))
$sel:withResponseAndRequest:WithMessage :: forall c.
WithMessage c
-> forall m rm req resp newReqParams newReqBody.
   (Show m, Show rm, Show req, Show newReqParams, Show newReqBody) =>
   (ResponseMessage resp -> FromServerMessage)
   -> (RequestMessage rm newReqParams newReqBody -> FromServerMessage)
   -> (LspFuncs c
       -> IdeState
       -> req
       -> IO (Either ResponseError resp, Maybe (rm, newReqParams)))
   -> Maybe (Handler (RequestMessage m req resp))
$sel:withInitialize:WithMessage :: forall c.
WithMessage c
-> (LspFuncs c -> IdeState -> InitializeParams -> IO ())
-> Maybe (Handler InitializeRequest)
..} Handlers
x ->
  Handlers -> IO Handlers
forall (m :: * -> *) a. Monad m => a -> m a
return Handlers
x {completionHandler :: Maybe (Handler CompletionRequest)
LSP.completionHandler = (ResponseMessage CompletionResponseResult -> FromServerMessage)
-> CompletionProvider -> Maybe (Handler CompletionRequest)
forall m req resp.
(Show m, Show req) =>
(ResponseMessage resp -> FromServerMessage)
-> (LspFuncs Config
    -> IdeState -> req -> IO (Either ResponseError resp))
-> Maybe (Handler (RequestMessage m req resp))
withResponse ResponseMessage CompletionResponseResult -> FromServerMessage
RspCompletion ([(PluginId, CompletionProvider)] -> CompletionProvider
makeCompletions [(PluginId, CompletionProvider)]
cps)}

makeCompletions :: [(PluginId, CompletionProvider)]
      -> LSP.LspFuncs Config
      -> IdeState
      -> CompletionParams
      -> IO (Either ResponseError CompletionResponseResult)
makeCompletions :: [(PluginId, CompletionProvider)] -> CompletionProvider
makeCompletions [(PluginId, CompletionProvider)]
sps LspFuncs Config
lf IdeState
ideState params :: CompletionParams
params@(CompletionParams (TextDocumentIdentifier Uri
doc) Position
pos Maybe CompletionContext
_context Maybe ProgressToken
_mt)
  = do
      Maybe PosPrefixInfo
mprefix <- LspFuncs Config -> Uri -> Position -> IO (Maybe PosPrefixInfo)
getPrefixAtPos LspFuncs Config
lf Uri
doc Position
pos
      WithSnippets
_snippets <- Bool -> WithSnippets
WithSnippets (Bool -> WithSnippets)
-> (Config -> Bool) -> Config -> WithSnippets
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Config -> Bool
completionSnippetsOn (Config -> WithSnippets) -> IO Config -> IO WithSnippets
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (LspFuncs Config -> IO Config
getClientConfig LspFuncs Config
lf)

      let
          combine :: [CompletionResponseResult] -> CompletionResponseResult
          combine :: [CompletionResponseResult] -> CompletionResponseResult
combine [CompletionResponseResult]
cs = CompletionResponseResult
-> [CompletionResponseResult] -> CompletionResponseResult
go (List CompletionItem -> CompletionResponseResult
Completions (List CompletionItem -> CompletionResponseResult)
-> List CompletionItem -> CompletionResponseResult
forall a b. (a -> b) -> a -> b
$ [CompletionItem] -> List CompletionItem
forall a. [a] -> List a
List []) [CompletionResponseResult]
cs
              where
                  go :: CompletionResponseResult
-> [CompletionResponseResult] -> CompletionResponseResult
go CompletionResponseResult
acc [] = CompletionResponseResult
acc
                  go (Completions (List [CompletionItem]
ls)) (Completions (List [CompletionItem]
ls2):[CompletionResponseResult]
rest)
                      = CompletionResponseResult
-> [CompletionResponseResult] -> CompletionResponseResult
go (List CompletionItem -> CompletionResponseResult
Completions ([CompletionItem] -> List CompletionItem
forall a. [a] -> List a
List ([CompletionItem]
ls [CompletionItem] -> [CompletionItem] -> [CompletionItem]
forall a. Semigroup a => a -> a -> a
<> [CompletionItem]
ls2))) [CompletionResponseResult]
rest
                  go (Completions (List [CompletionItem]
ls)) (CompletionList (CompletionListType Bool
complete (List [CompletionItem]
ls2)):[CompletionResponseResult]
rest)
                      = CompletionResponseResult
-> [CompletionResponseResult] -> CompletionResponseResult
go (CompletionListType -> CompletionResponseResult
CompletionList (CompletionListType -> CompletionResponseResult)
-> CompletionListType -> CompletionResponseResult
forall a b. (a -> b) -> a -> b
$ Bool -> List CompletionItem -> CompletionListType
CompletionListType Bool
complete ([CompletionItem] -> List CompletionItem
forall a. [a] -> List a
List ([CompletionItem]
ls [CompletionItem] -> [CompletionItem] -> [CompletionItem]
forall a. Semigroup a => a -> a -> a
<> [CompletionItem]
ls2))) [CompletionResponseResult]
rest
                  go (CompletionList (CompletionListType Bool
complete (List [CompletionItem]
ls))) (CompletionList (CompletionListType Bool
complete2 (List [CompletionItem]
ls2)):[CompletionResponseResult]
rest)
                      = CompletionResponseResult
-> [CompletionResponseResult] -> CompletionResponseResult
go (CompletionListType -> CompletionResponseResult
CompletionList (CompletionListType -> CompletionResponseResult)
-> CompletionListType -> CompletionResponseResult
forall a b. (a -> b) -> a -> b
$ Bool -> List CompletionItem -> CompletionListType
CompletionListType (Bool
complete Bool -> Bool -> Bool
|| Bool
complete2) ([CompletionItem] -> List CompletionItem
forall a. [a] -> List a
List ([CompletionItem]
ls [CompletionItem] -> [CompletionItem] -> [CompletionItem]
forall a. Semigroup a => a -> a -> a
<> [CompletionItem]
ls2))) [CompletionResponseResult]
rest
                  go (CompletionList (CompletionListType Bool
complete (List [CompletionItem]
ls))) (Completions (List [CompletionItem]
ls2):[CompletionResponseResult]
rest)
                      = CompletionResponseResult
-> [CompletionResponseResult] -> CompletionResponseResult
go (CompletionListType -> CompletionResponseResult
CompletionList (CompletionListType -> CompletionResponseResult)
-> CompletionListType -> CompletionResponseResult
forall a b. (a -> b) -> a -> b
$ Bool -> List CompletionItem -> CompletionListType
CompletionListType Bool
complete ([CompletionItem] -> List CompletionItem
forall a. [a] -> List a
List ([CompletionItem]
ls [CompletionItem] -> [CompletionItem] -> [CompletionItem]
forall a. Semigroup a => a -> a -> a
<> [CompletionItem]
ls2))) [CompletionResponseResult]
rest

      case Maybe PosPrefixInfo
mprefix of
          Maybe PosPrefixInfo
Nothing -> Either ResponseError CompletionResponseResult
-> IO (Either ResponseError CompletionResponseResult)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ResponseError CompletionResponseResult
 -> IO (Either ResponseError CompletionResponseResult))
-> Either ResponseError CompletionResponseResult
-> IO (Either ResponseError CompletionResponseResult)
forall a b. (a -> b) -> a -> b
$ CompletionResponseResult
-> Either ResponseError CompletionResponseResult
forall a b. b -> Either a b
Right (CompletionResponseResult
 -> Either ResponseError CompletionResponseResult)
-> CompletionResponseResult
-> Either ResponseError CompletionResponseResult
forall a b. (a -> b) -> a -> b
$ List CompletionItem -> CompletionResponseResult
Completions (List CompletionItem -> CompletionResponseResult)
-> List CompletionItem -> CompletionResponseResult
forall a b. (a -> b) -> a -> b
$ [CompletionItem] -> List CompletionItem
forall a. [a] -> List a
List []
          Just PosPrefixInfo
_prefix -> do
            [Either ResponseError CompletionResponseResult]
mhs <- ((PluginId, CompletionProvider)
 -> IO (Either ResponseError CompletionResponseResult))
-> [(PluginId, CompletionProvider)]
-> IO [Either ResponseError CompletionResponseResult]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(PluginId
_,CompletionProvider
p) -> CompletionProvider
p LspFuncs Config
lf IdeState
ideState CompletionParams
params) [(PluginId, CompletionProvider)]
sps
            case [Either ResponseError CompletionResponseResult]
-> [CompletionResponseResult]
forall a b. [Either a b] -> [b]
rights [Either ResponseError CompletionResponseResult]
mhs of
                [] -> Either ResponseError CompletionResponseResult
-> IO (Either ResponseError CompletionResponseResult)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ResponseError CompletionResponseResult
 -> IO (Either ResponseError CompletionResponseResult))
-> Either ResponseError CompletionResponseResult
-> IO (Either ResponseError CompletionResponseResult)
forall a b. (a -> b) -> a -> b
$ ResponseError -> Either ResponseError CompletionResponseResult
forall a b. a -> Either a b
Left (ResponseError -> Either ResponseError CompletionResponseResult)
-> ResponseError -> Either ResponseError CompletionResponseResult
forall a b. (a -> b) -> a -> b
$ Text -> ResponseError
responseError (Text -> ResponseError) -> Text -> ResponseError
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ [ResponseError] -> String
forall a. Show a => a -> String
show ([ResponseError] -> String) -> [ResponseError] -> String
forall a b. (a -> b) -> a -> b
$ [Either ResponseError CompletionResponseResult] -> [ResponseError]
forall a b. [Either a b] -> [a]
lefts [Either ResponseError CompletionResponseResult]
mhs
                [CompletionResponseResult]
hs -> Either ResponseError CompletionResponseResult
-> IO (Either ResponseError CompletionResponseResult)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ResponseError CompletionResponseResult
 -> IO (Either ResponseError CompletionResponseResult))
-> Either ResponseError CompletionResponseResult
-> IO (Either ResponseError CompletionResponseResult)
forall a b. (a -> b) -> a -> b
$ CompletionResponseResult
-> Either ResponseError CompletionResponseResult
forall a b. b -> Either a b
Right (CompletionResponseResult
 -> Either ResponseError CompletionResponseResult)
-> CompletionResponseResult
-> Either ResponseError CompletionResponseResult
forall a b. (a -> b) -> a -> b
$ [CompletionResponseResult] -> CompletionResponseResult
combine [CompletionResponseResult]
hs

{-
        ReqCompletion req -> do
          liftIO $ U.logs $ "reactor:got CompletionRequest:" ++ show req
          let (_, doc, pos) = reqParams req

          mprefix <- getPrefixAtPos doc pos

          let callback compls = do
                let rspMsg = Core.makeResponseMessage req
                              $ J.Completions $ J.List compls
                reactorSend $ RspCompletion rspMsg
          case mprefix of
            Nothing -> callback []
            Just prefix -> do
              snippets <- Completions.WithSnippets <$> configVal completionSnippetsOn
              let hreq = IReq tn "completion" (req ^. J.id) callback
                           $ lift $ Completions.getCompletions doc prefix snippets
              makeRequest hreq
-}

getPrefixAtPos :: LSP.LspFuncs Config -> Uri -> Position -> IO (Maybe VFS.PosPrefixInfo)
getPrefixAtPos :: LspFuncs Config -> Uri -> Position -> IO (Maybe PosPrefixInfo)
getPrefixAtPos LspFuncs Config
lf Uri
uri Position
pos = do
  Maybe VirtualFile
mvf <-  (LspFuncs Config -> NormalizedUri -> IO (Maybe VirtualFile)
forall c. LspFuncs c -> NormalizedUri -> IO (Maybe VirtualFile)
LSP.getVirtualFileFunc LspFuncs Config
lf) (Uri -> NormalizedUri
J.toNormalizedUri Uri
uri)
  case Maybe VirtualFile
mvf of
    Just VirtualFile
vf -> Position -> VirtualFile -> IO (Maybe PosPrefixInfo)
forall (m :: * -> *).
Monad m =>
Position -> VirtualFile -> m (Maybe PosPrefixInfo)
VFS.getCompletionPrefix Position
pos VirtualFile
vf
    Maybe VirtualFile
Nothing -> Maybe PosPrefixInfo -> IO (Maybe PosPrefixInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe PosPrefixInfo
forall a. Maybe a
Nothing

-- ---------------------------------------------------------------------
-- | Returns the current client configuration. It is not wise to permanently
-- cache the returned value of this function, as clients can at runitime change
-- their configuration.
--
-- If no custom configuration has been set by the client, this function returns
-- our own defaults.
getClientConfig :: LSP.LspFuncs Config -> IO Config
getClientConfig :: LspFuncs Config -> IO Config
getClientConfig LspFuncs Config
lf = Config -> Maybe Config -> Config
forall a. a -> Maybe a -> a
fromMaybe Config
forall a. Default a => a
Data.Default.def (Maybe Config -> Config) -> IO (Maybe Config) -> IO Config
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LspFuncs Config -> IO (Maybe Config)
forall c. LspFuncs c -> IO (Maybe c)
LSP.config LspFuncs Config
lf

-- | Returns the client configurarion stored in the IdeState.
-- You can use this function to access it from shake Rules
getClientConfigAction :: Action Config
getClientConfigAction :: Action Config
getClientConfigAction = do
  Maybe Value
mbVal <- Hashed (Maybe Value) -> Maybe Value
forall a. Hashed a -> a
unhashed (Hashed (Maybe Value) -> Maybe Value)
-> Action (Hashed (Maybe Value)) -> Action (Maybe Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GetClientSettings -> Action (Hashed (Maybe Value))
forall k v. IdeRule k v => k -> Action v
useNoFile_ GetClientSettings
GetClientSettings
  String -> Action ()
forall (m :: * -> *). MonadIO m => String -> m ()
logm (String -> Action ()) -> String -> Action ()
forall a b. (a -> b) -> a -> b
$ String
"getClientConfigAction:clientSettings:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe Value -> String
forall a. Show a => a -> String
show Maybe Value
mbVal
  case Value -> Result Config
forall a. FromJSON a => Value -> Result a
J.fromJSON (Value -> Result Config) -> Maybe Value -> Maybe (Result Config)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Value
mbVal of
    Just (J.Success Config
c) -> Config -> Action Config
forall (m :: * -> *) a. Monad m => a -> m a
return Config
c
    Maybe (Result Config)
_ -> Config -> Action Config
forall (m :: * -> *) a. Monad m => a -> m a
return Config
forall a. Default a => a
Data.Default.def
-- ---------------------------------------------------------------------