{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE OverloadedLabels    #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE RecursiveDo         #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving  #-}
{-# LANGUAGE TypeInType          #-}

{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
-- there's just so much!
{-# OPTIONS_GHC -Wno-name-shadowing #-}
-- So we can keep using the old prettyprinter modules (which have a better
-- compatibility range) for now.
{-# OPTIONS_GHC -Wno-deprecations #-}

module Language.LSP.Server.Processing where

import           Colog.Core                             (LogAction (..),
                                                         Severity (..),
                                                         WithSeverity (..),
                                                         cmap, (<&))

import           Control.Concurrent.STM
import qualified Control.Exception                      as E
import           Control.Lens                           hiding (Empty)
import           Control.Monad
import           Control.Monad.Except                   ()
import           Control.Monad.IO.Class
import           Control.Monad.Reader
import           Control.Monad.State
import           Control.Monad.Trans.Except
import           Control.Monad.Writer.Strict
import           Data.Aeson                             hiding (Error, Null,
                                                         Options)
import           Data.Aeson.Lens                        ()
import           Data.Aeson.Types                       hiding (Error, Null,
                                                         Options)
import qualified Data.ByteString.Lazy                   as BSL
import           Data.Foldable                          (traverse_)
import qualified Data.Functor.Product                   as P
import           Data.IxMap
import           Data.List
import           Data.List.NonEmpty                     (NonEmpty (..))
import qualified Data.Map.Strict                        as Map
import           Data.Maybe
import           Data.Monoid
import           Data.Row
import           Data.String                            (fromString)
import qualified Data.Text                              as T
import qualified Data.Text.Lazy.Encoding                as TL
import           Data.Text.Prettyprint.Doc
import qualified Language.LSP.Protocol.Lens             as L
import           Language.LSP.Protocol.Message
import           Language.LSP.Protocol.Types
import           Language.LSP.Protocol.Utils.SMethodMap (SMethodMap)
import qualified Language.LSP.Protocol.Utils.SMethodMap as SMethodMap
import           Language.LSP.Server.Core
import           Language.LSP.VFS                       as VFS
import           System.Exit

data LspProcessingLog =
  VfsLog VfsLog
  | LspCore LspCoreLog
  | MessageProcessingError BSL.ByteString String
  | forall m . MissingHandler Bool (SClientMethod m)
  | ProgressCancel ProgressToken
  | Exiting

deriving instance Show LspProcessingLog

instance Pretty LspProcessingLog where
  pretty :: forall ann. LspProcessingLog -> Doc ann
pretty (VfsLog VfsLog
l) = forall a ann. Pretty a => a -> Doc ann
pretty VfsLog
l
  pretty (LspCore LspCoreLog
l) = forall a ann. Pretty a => a -> Doc ann
pretty LspCoreLog
l
  pretty (MessageProcessingError ByteString
bs String
err) =
    forall ann. [Doc ann] -> Doc ann
vsep [
      Doc ann
"LSP: incoming message parse error:"
      , forall a ann. Pretty a => a -> Doc ann
pretty String
err
      , Doc ann
"when processing"
      , forall a ann. Pretty a => a -> Doc ann
pretty (ByteString -> Text
TL.decodeUtf8 ByteString
bs)
      ]
  pretty (MissingHandler Bool
_ SClientMethod @t m
m) = Doc ann
"LSP: no handler for:" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty SClientMethod @t m
m
  pretty (ProgressCancel ProgressToken
tid) = Doc ann
"LSP: cancelling action for token:" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty ProgressToken
tid
  pretty LspProcessingLog
Exiting = Doc ann
"LSP: Got exit, exiting"

processMessage :: (m ~ LspM config) => LogAction m (WithSeverity LspProcessingLog) -> BSL.ByteString -> m ()
processMessage :: forall (m :: * -> *) config.
((m :: (* -> *)) ~ (LspM config :: (* -> *))) =>
LogAction m (WithSeverity LspProcessingLog) -> ByteString -> m ()
processMessage LogAction m (WithSeverity LspProcessingLog)
logger ByteString
jsonStr = do
  TVar ResponseMap
pendingResponsesVar <- forall config (m :: * -> *) a.
ReaderT (LanguageContextEnv config) m a -> LspT config m a
LspT forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a b. (a -> b) -> a -> b
$ forall config. LanguageContextState config -> TVar ResponseMap
resPendingResponses forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall config.
LanguageContextEnv config -> LanguageContextState config
resState
  forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either String (m ()) -> m ()
handleErrors forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ do
      Value
val <- forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except forall a b. (a -> b) -> a -> b
$ forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
jsonStr
      ResponseMap
pending <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> STM a
readTVar TVar ResponseMap
pendingResponsesVar
      FromClientMessage'
  (Product
     @(Method 'ServerToClient 'Request)
     ServerResponseCallback
     (Const @(Method 'ServerToClient 'Request) ResponseMap))
msg <- forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Parser b) -> a -> Either String b
parseEither (ResponseMap
-> Value
-> Parser
     (FromClientMessage'
        (Product
           @(Method 'ServerToClient 'Request)
           ServerResponseCallback
           (Const @(Method 'ServerToClient 'Request) ResponseMap)))
parser ResponseMap
pending) Value
val
      forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ case FromClientMessage'
  (Product
     @(Method 'ServerToClient 'Request)
     ServerResponseCallback
     (Const @(Method 'ServerToClient 'Request) ResponseMap))
msg of
        FromClientMess SMethod @'ClientToServer @t m
m TMessage @'ClientToServer @t m
mess ->
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall {t :: MessageKind} (m :: * -> *) config
       (meth :: Method 'ClientToServer t).
((m :: (* -> *)) ~ (LspM config :: (* -> *))) =>
LogAction m (WithSeverity LspProcessingLog)
-> SClientMethod @t meth -> TClientMessage @t meth -> m ()
handle LogAction m (WithSeverity LspProcessingLog)
logger SMethod @'ClientToServer @t m
m TMessage @'ClientToServer @t m
mess
        FromClientRsp (P.Pair (ServerResponseCallback Either ResponseError (MessageResult @'ServerToClient @'Request m)
-> IO ()
f) (Const !ResponseMap
newMap)) TResponseMessage @'ServerToClient m
res -> do
          forall a. TVar a -> a -> STM ()
writeTVar TVar ResponseMap
pendingResponsesVar ResponseMap
newMap
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Either ResponseError (MessageResult @'ServerToClient @'Request m)
-> IO ()
f (TResponseMessage @'ServerToClient m
res forall s a. s -> Getting a s a -> a
^. forall s a. HasResult s a => Lens' s a
L.result)
  where
    parser :: ResponseMap -> Value -> Parser (FromClientMessage' (P.Product ServerResponseCallback (Const ResponseMap)))
    parser :: ResponseMap
-> Value
-> Parser
     (FromClientMessage'
        (Product
           @(Method 'ServerToClient 'Request)
           ServerResponseCallback
           (Const @(Method 'ServerToClient 'Request) ResponseMap)))
parser ResponseMap
rm = forall (a :: Method 'ServerToClient 'Request -> *).
LookupFunc 'ServerToClient a
-> Value -> Parser (FromClientMessage' a)
parseClientMessage forall a b. (a -> b) -> a -> b
$ \LspId @'ServerToClient m
i ->
      let (Maybe
  (Product
     @(Method 'ServerToClient 'Request)
     (SMethod @'ServerToClient @'Request)
     ServerResponseCallback
     m)
mhandler, ResponseMap
newMap) = forall {a} (k :: a -> *) (m :: a) (f :: a -> *).
IxOrd @a k =>
k m -> IxMap @a k f -> (Maybe (f m), IxMap @a k f)
pickFromIxMap LspId @'ServerToClient m
i ResponseMap
rm
        in (\(P.Pair SMethod @'ServerToClient @'Request m
m ServerResponseCallback m
handler) -> (SMethod @'ServerToClient @'Request m
m,forall {k} (f :: k -> *) (g :: k -> *) (a :: k).
f a -> g a -> Product @k f g a
P.Pair ServerResponseCallback m
handler (forall {k} a (b :: k). a -> Const @k a b
Const ResponseMap
newMap))) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe
  (Product
     @(Method 'ServerToClient 'Request)
     (SMethod @'ServerToClient @'Request)
     ServerResponseCallback
     m)
mhandler

    handleErrors :: Either String (m ()) -> m ()
handleErrors = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\String
e -> LogAction m (WithSeverity LspProcessingLog)
logger forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& ByteString -> String -> LspProcessingLog
MessageProcessingError ByteString
jsonStr String
e forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` Severity
Error) forall a. a -> a
id

-- | Call this to initialize the session
initializeRequestHandler
  :: LogAction IO (WithSeverity LspProcessingLog)
  -> ServerDefinition config
  -> VFS
  -> (FromServerMessage -> IO ())
  -> TMessage Method_Initialize
  -> IO (Maybe (LanguageContextEnv config))
initializeRequestHandler :: forall config.
LogAction IO (WithSeverity LspProcessingLog)
-> ServerDefinition config
-> VFS
-> (FromServerMessage -> IO ())
-> TMessage @'ClientToServer @'Request 'Method_Initialize
-> IO (Maybe (LanguageContextEnv config))
initializeRequestHandler LogAction IO (WithSeverity LspProcessingLog)
logger ServerDefinition{config
Text
Options
config -> m ()
config -> Value -> Either Text config
a -> (<~>) @(*) m IO
ClientCapabilities -> Handlers m
LanguageContextEnv config
-> TMessage @'ClientToServer @'Request 'Method_Initialize
-> IO (Either ResponseError a)
options :: forall config. ServerDefinition config -> Options
interpretHandler :: ()
staticHandlers :: ()
doInitialize :: ()
onConfigChange :: ()
parseConfig :: forall config.
ServerDefinition config -> config -> Value -> Either Text config
configSection :: forall config. ServerDefinition config -> Text
defaultConfig :: forall config. ServerDefinition config -> config
options :: Options
interpretHandler :: a -> (<~>) @(*) m IO
staticHandlers :: ClientCapabilities -> Handlers m
doInitialize :: LanguageContextEnv config
-> TMessage @'ClientToServer @'Request 'Method_Initialize
-> IO (Either ResponseError a)
onConfigChange :: config -> m ()
parseConfig :: config -> Value -> Either Text config
configSection :: Text
defaultConfig :: config
..} VFS
vfs FromServerMessage -> IO ()
sendFunc TMessage @'ClientToServer @'Request 'Method_Initialize
req = do
  let sendResp :: TResponseMessage @'ClientToServer 'Method_Initialize -> IO ()
sendResp = FromServerMessage -> IO ()
sendFunc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: Method 'ClientToServer 'Request)
       (a :: Method 'ClientToServer 'Request -> *).
a m -> TResponseMessage @'ClientToServer m -> FromServerMessage' a
FromServerRsp SMethod @'ClientToServer @'Request 'Method_Initialize
SMethod_Initialize
      handleErr :: Either ResponseError (LanguageContextEnv config)
-> IO (Maybe (LanguageContextEnv config))
handleErr (Left ResponseError
err) = do
        TResponseMessage @'ClientToServer 'Method_Initialize -> IO ()
sendResp forall a b. (a -> b) -> a -> b
$ forall {f :: MessageDirection} {m :: Method f 'Request}.
LspId @f m -> ResponseError -> TResponseMessage @f m
makeResponseError (TMessage @'ClientToServer @'Request 'Method_Initialize
req forall s a. s -> Getting a s a -> a
^. forall s a. HasId s a => Lens' s a
L.id) ResponseError
err
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
      handleErr (Right LanguageContextEnv config
a) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just LanguageContextEnv config
a
  forall a b c. (a -> b -> c) -> b -> a -> c
flip forall e a. Exception e => IO a -> (e -> IO a) -> IO a
E.catch (forall a. (ResponseError -> IO ()) -> SomeException -> IO (Maybe a)
initializeErrorHandler forall a b. (a -> b) -> a -> b
$ TResponseMessage @'ClientToServer 'Method_Initialize -> IO ()
sendResp forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {f :: MessageDirection} {m :: Method f 'Request}.
LspId @f m -> ResponseError -> TResponseMessage @f m
makeResponseError (TMessage @'ClientToServer @'Request 'Method_Initialize
req forall s a. s -> Getting a s a -> a
^. forall s a. HasId s a => Lens' s a
L.id)) forall a b. (a -> b) -> a -> b
$ Either ResponseError (LanguageContextEnv config)
-> IO (Maybe (LanguageContextEnv config))
handleErr forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ mdo

    let p :: InitializeParams
p = TMessage @'ClientToServer @'Request 'Method_Initialize
req forall s a. s -> Getting a s a -> a
^. forall s a. HasParams s a => Lens' s a
L.params
        rootDir :: Maybe String
rootDir = forall a. First a -> Maybe a
getFirst forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall a. Maybe a -> First a
First [ InitializeParams
p forall s a. s -> Getting (First a) s a -> Maybe a
^? forall s a. HasRootUri s a => Lens' s a
L.rootUri forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism' (a |? b) a
_L forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Uri -> Maybe String
uriToFilePath
                                           , InitializeParams
p forall s a. s -> Getting (First a) s a -> Maybe a
^? forall s a. HasRootPath s a => Lens' s a
L.rootPath forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism' (a |? b) a
_L forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Text -> String
T.unpack ]
        clientCaps :: ClientCapabilities
clientCaps = (InitializeParams
p forall s a. s -> Getting a s a -> a
^. forall s a. HasCapabilities s a => Lens' s a
L.capabilities)

    let initialWfs :: [WorkspaceFolder]
initialWfs = case InitializeParams
p forall s a. s -> Getting a s a -> a
^. forall s a. HasWorkspaceFolders s a => Lens' s a
L.workspaceFolders of
          Just (InL [WorkspaceFolder]
xs) -> [WorkspaceFolder]
xs
          Maybe ([WorkspaceFolder] |? Null)
_             -> []

        -- See Note [LSP configuration]
        configObject :: Maybe Value
configObject = Text -> Value -> Value
lookForConfigSection Text
configSection forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (InitializeParams
p forall s a. s -> Getting a s a -> a
^. forall s a. HasInitializationOptions s a => Lens' s a
L.initializationOptions)

    config
initialConfig <- case Maybe Value
configObject of
      Just Value
o -> case config -> Value -> Either Text config
parseConfig config
defaultConfig Value
o of
          Right config
newConfig -> forall (f :: * -> *) a. Applicative f => a -> f a
pure config
newConfig
          Left Text
err -> do
            -- Warn not error here, since initializationOptions is pretty unspecified
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ LogAction IO (WithSeverity LspProcessingLog)
logger forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& (LspCoreLog -> LspProcessingLog
LspCore forall a b. (a -> b) -> a -> b
$ Value -> Text -> LspCoreLog
ConfigurationParseError Value
o Text
err) forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` Severity
Warning
            forall (f :: * -> *) a. Applicative f => a -> f a
pure config
defaultConfig
      Maybe Value
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure config
defaultConfig

    LanguageContextState config
stateVars <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
      TVar VFSData
resVFS              <- forall a. a -> IO (TVar a)
newTVarIO (VFS -> Map String String -> VFSData
VFSData VFS
vfs forall a. Monoid a => a
mempty)
      TVar DiagnosticStore
resDiagnostics      <- forall a. a -> IO (TVar a)
newTVarIO forall a. Monoid a => a
mempty
      TVar config
resConfig           <- forall a. a -> IO (TVar a)
newTVarIO config
initialConfig
      TVar [WorkspaceFolder]
resWorkspaceFolders <- forall a. a -> IO (TVar a)
newTVarIO [WorkspaceFolder]
initialWfs
      ProgressData
resProgressData     <- do
        TVar Int32
progressNextId <- forall a. a -> IO (TVar a)
newTVarIO Int32
0
        TVar (Map ProgressToken (IO ()))
progressCancel <- forall a. a -> IO (TVar a)
newTVarIO forall a. Monoid a => a
mempty
        forall (f :: * -> *) a. Applicative f => a -> f a
pure ProgressData{TVar Int32
TVar (Map ProgressToken (IO ()))
progressCancel :: TVar (Map ProgressToken (IO ()))
progressNextId :: TVar Int32
progressCancel :: TVar (Map ProgressToken (IO ()))
progressNextId :: TVar Int32
..}
      TVar ResponseMap
resPendingResponses <- forall a. a -> IO (TVar a)
newTVarIO forall {a} (k :: a -> *) (f :: a -> *). IxMap @a k f
emptyIxMap
      TVar (RegistrationMap 'Notification)
resRegistrationsNot <- forall a. a -> IO (TVar a)
newTVarIO forall a. Monoid a => a
mempty
      TVar (RegistrationMap 'Request)
resRegistrationsReq <- forall a. a -> IO (TVar a)
newTVarIO forall a. Monoid a => a
mempty
      TVar Int32
resLspId            <- forall a. a -> IO (TVar a)
newTVarIO Int32
0
      forall (f :: * -> *) a. Applicative f => a -> f a
pure LanguageContextState{TVar config
TVar Int32
TVar [WorkspaceFolder]
TVar DiagnosticStore
TVar (RegistrationMap 'Request)
TVar (RegistrationMap 'Notification)
TVar ResponseMap
TVar VFSData
ProgressData
resLspId :: TVar Int32
resRegistrationsReq :: TVar (RegistrationMap 'Request)
resRegistrationsNot :: TVar (RegistrationMap 'Notification)
resProgressData :: ProgressData
resWorkspaceFolders :: TVar [WorkspaceFolder]
resConfig :: TVar config
resDiagnostics :: TVar DiagnosticStore
resVFS :: TVar VFSData
resLspId :: TVar Int32
resRegistrationsReq :: TVar (RegistrationMap 'Request)
resRegistrationsNot :: TVar (RegistrationMap 'Notification)
resPendingResponses :: TVar ResponseMap
resProgressData :: ProgressData
resWorkspaceFolders :: TVar [WorkspaceFolder]
resConfig :: TVar config
resDiagnostics :: TVar DiagnosticStore
resVFS :: TVar VFSData
resPendingResponses :: TVar ResponseMap
..}

    -- Call the 'duringInitialization' callback to let the server kick stuff up
    let env :: LanguageContextEnv config
env = forall config.
Handlers IO
-> Text
-> (config -> Value -> Either Text config)
-> (config -> IO ())
-> (FromServerMessage -> IO ())
-> LanguageContextState config
-> ClientCapabilities
-> Maybe String
-> LanguageContextEnv config
LanguageContextEnv Handlers IO
handlers Text
configSection config -> Value -> Either Text config
parseConfig config -> IO ()
configChanger FromServerMessage -> IO ()
sendFunc LanguageContextState config
stateVars (InitializeParams
p forall s a. s -> Getting a s a -> a
^. forall s a. HasCapabilities s a => Lens' s a
L.capabilities) Maybe String
rootDir
        configChanger :: config -> IO ()
configChanger config
config = forall {k} (m :: k -> *) (n :: k -> *).
(<~>) @k m n -> forall (a :: k). m a -> n a
forward (<~>) @(*) m IO
interpreter (config -> m ()
onConfigChange config
config)
        handlers :: Handlers IO
handlers = forall (m :: * -> *) (n :: * -> *).
(<~>) @(*) m n -> Handlers m -> Handlers n
transmuteHandlers (<~>) @(*) m IO
interpreter (ClientCapabilities -> Handlers m
staticHandlers ClientCapabilities
clientCaps)
        interpreter :: (<~>) @(*) m IO
interpreter = a -> (<~>) @(*) m IO
interpretHandler a
initializationResult
    a
initializationResult <- forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ LanguageContextEnv config
-> TMessage @'ClientToServer @'Request 'Method_Initialize
-> IO (Either ResponseError a)
doInitialize LanguageContextEnv config
env TMessage @'ClientToServer @'Request 'Method_Initialize
req

    let serverCaps :: ServerCapabilities
serverCaps = forall (m :: * -> *).
ClientCapabilities -> Options -> Handlers m -> ServerCapabilities
inferServerCapabilities ClientCapabilities
clientCaps Options
options Handlers IO
handlers
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ TResponseMessage @'ClientToServer 'Method_Initialize -> IO ()
sendResp forall a b. (a -> b) -> a -> b
$ forall {f :: MessageDirection} {m :: Method f 'Request}.
LspId @f m -> MessageResult @f @'Request m -> TResponseMessage @f m
makeResponseMessage (TMessage @'ClientToServer @'Request 'Method_Initialize
req forall s a. s -> Getting a s a -> a
^. forall s a. HasId s a => Lens' s a
L.id) (ServerCapabilities
-> Maybe
     (Rec
        ((.+)
           @(*)
           ((.==) @(*) "name" Text)
           ((.+) @(*) ((.==) @(*) "version" (Maybe Text)) (Empty @(*)))))
-> InitializeResult
InitializeResult ServerCapabilities
serverCaps (Options
-> Maybe
     (Rec
        ((.+)
           @(*) ((.==) @(*) "name" Text) ((.==) @(*) "version" (Maybe Text))))
optServerInfo Options
options))
    forall (f :: * -> *) a. Applicative f => a -> f a
pure LanguageContextEnv config
env
  where
    makeResponseMessage :: LspId @f m -> MessageResult @f @'Request m -> TResponseMessage @f m
makeResponseMessage LspId @f m
rid MessageResult @f @'Request m
result = forall (f :: MessageDirection) (m :: Method f 'Request).
Text
-> Maybe (LspId @f m)
-> Either ResponseError (MessageResult @f @'Request m)
-> TResponseMessage @f m
TResponseMessage Text
"2.0" (forall a. a -> Maybe a
Just LspId @f m
rid) (forall a b. b -> Either a b
Right MessageResult @f @'Request m
result)
    makeResponseError :: LspId @f m -> ResponseError -> TResponseMessage @f m
makeResponseError LspId @f m
origId ResponseError
err = forall (f :: MessageDirection) (m :: Method f 'Request).
Text
-> Maybe (LspId @f m)
-> Either ResponseError (MessageResult @f @'Request m)
-> TResponseMessage @f m
TResponseMessage Text
"2.0" (forall a. a -> Maybe a
Just LspId @f m
origId) (forall a b. a -> Either a b
Left ResponseError
err)

    initializeErrorHandler :: (ResponseError -> IO ()) -> E.SomeException -> IO (Maybe a)
    initializeErrorHandler :: forall a. (ResponseError -> IO ()) -> SomeException -> IO (Maybe a)
initializeErrorHandler ResponseError -> IO ()
sendResp SomeException
e = do
        ResponseError -> IO ()
sendResp forall a b. (a -> b) -> a -> b
$ (LSPErrorCodes |? ErrorCodes)
-> Text -> Maybe Value -> ResponseError
ResponseError (forall a b. b -> a |? b
InR ErrorCodes
ErrorCodes_InternalError) Text
msg forall a. Maybe a
Nothing
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
      where
        msg :: Text
msg = String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String
"Error on initialize:", forall a. Show a => a -> String
show SomeException
e]


-- | Infers the capabilities based on registered handlers, and sets the appropriate options.
-- A provider should be set to Nothing if the server does not support it, unless it is a
-- static option.
inferServerCapabilities :: ClientCapabilities -> Options -> Handlers m -> ServerCapabilities
inferServerCapabilities :: forall (m :: * -> *).
ClientCapabilities -> Options -> Handlers m -> ServerCapabilities
inferServerCapabilities ClientCapabilities
clientCaps Options
o Handlers m
h =
  ServerCapabilities
    { $sel:_textDocumentSync:ServerCapabilities :: Maybe (TextDocumentSyncOptions |? TextDocumentSyncKind)
_textDocumentSync                 = Maybe (TextDocumentSyncOptions |? TextDocumentSyncKind)
sync
    , $sel:_hoverProvider:ServerCapabilities :: Maybe (Bool |? HoverOptions)
_hoverProvider                    = forall {t :: MessageKind} {m :: Method 'ClientToServer t} {b}.
SClientMethod @t m -> Maybe (Bool |? b)
supportedBool SMethod @'ClientToServer @'Request 'Method_TextDocumentHover
SMethod_TextDocumentHover
    , $sel:_completionProvider:ServerCapabilities :: Maybe CompletionOptions
_completionProvider               = Maybe CompletionOptions
completionProvider
    , $sel:_declarationProvider:ServerCapabilities :: Maybe
  (Bool |? (DeclarationOptions |? DeclarationRegistrationOptions))
_declarationProvider              = forall {t :: MessageKind} {m :: Method 'ClientToServer t} {b}.
SClientMethod @t m -> Maybe (Bool |? b)
supportedBool SMethod @'ClientToServer @'Request 'Method_TextDocumentDeclaration
SMethod_TextDocumentDeclaration
    , $sel:_signatureHelpProvider:ServerCapabilities :: Maybe SignatureHelpOptions
_signatureHelpProvider            = Maybe SignatureHelpOptions
signatureHelpProvider
    , $sel:_definitionProvider:ServerCapabilities :: Maybe (Bool |? DefinitionOptions)
_definitionProvider               = forall {t :: MessageKind} {m :: Method 'ClientToServer t} {b}.
SClientMethod @t m -> Maybe (Bool |? b)
supportedBool SMethod @'ClientToServer @'Request 'Method_TextDocumentDefinition
SMethod_TextDocumentDefinition
    , $sel:_typeDefinitionProvider:ServerCapabilities :: Maybe
  (Bool
   |? (TypeDefinitionOptions |? TypeDefinitionRegistrationOptions))
_typeDefinitionProvider           = forall {t :: MessageKind} {m :: Method 'ClientToServer t} {b}.
SClientMethod @t m -> Maybe (Bool |? b)
supportedBool SMethod
  @'ClientToServer @'Request 'Method_TextDocumentTypeDefinition
SMethod_TextDocumentTypeDefinition
    , $sel:_implementationProvider:ServerCapabilities :: Maybe
  (Bool
   |? (ImplementationOptions |? ImplementationRegistrationOptions))
_implementationProvider           = forall {t :: MessageKind} {m :: Method 'ClientToServer t} {b}.
SClientMethod @t m -> Maybe (Bool |? b)
supportedBool SMethod
  @'ClientToServer @'Request 'Method_TextDocumentImplementation
SMethod_TextDocumentImplementation
    , $sel:_referencesProvider:ServerCapabilities :: Maybe (Bool |? ReferenceOptions)
_referencesProvider               = forall {t :: MessageKind} {m :: Method 'ClientToServer t} {b}.
SClientMethod @t m -> Maybe (Bool |? b)
supportedBool SMethod @'ClientToServer @'Request 'Method_TextDocumentReferences
SMethod_TextDocumentReferences
    , $sel:_documentHighlightProvider:ServerCapabilities :: Maybe (Bool |? DocumentHighlightOptions)
_documentHighlightProvider        = forall {t :: MessageKind} {m :: Method 'ClientToServer t} {b}.
SClientMethod @t m -> Maybe (Bool |? b)
supportedBool SMethod
  @'ClientToServer @'Request 'Method_TextDocumentDocumentHighlight
SMethod_TextDocumentDocumentHighlight
    , $sel:_documentSymbolProvider:ServerCapabilities :: Maybe (Bool |? DocumentSymbolOptions)
_documentSymbolProvider           = forall {t :: MessageKind} {m :: Method 'ClientToServer t} {b}.
SClientMethod @t m -> Maybe (Bool |? b)
supportedBool SMethod
  @'ClientToServer @'Request 'Method_TextDocumentDocumentSymbol
SMethod_TextDocumentDocumentSymbol
    , $sel:_codeActionProvider:ServerCapabilities :: Maybe (Bool |? CodeActionOptions)
_codeActionProvider               = Maybe (Bool |? CodeActionOptions)
codeActionProvider
    , $sel:_codeLensProvider:ServerCapabilities :: Maybe CodeLensOptions
_codeLensProvider                 = forall {t :: MessageKind} {m :: Method 'ClientToServer t} {a}.
SClientMethod @t m -> a -> Maybe a
supported' SMethod @'ClientToServer @'Request 'Method_TextDocumentCodeLens
SMethod_TextDocumentCodeLens forall a b. (a -> b) -> a -> b
$ Maybe Bool -> Maybe Bool -> CodeLensOptions
CodeLensOptions
                                              (forall a. a -> Maybe a
Just Bool
False)
                                              (forall {t :: MessageKind} (m :: Method 'ClientToServer t).
SClientMethod @t m -> Maybe Bool
supported SMethod @'ClientToServer @'Request 'Method_CodeLensResolve
SMethod_CodeLensResolve)
    , $sel:_documentFormattingProvider:ServerCapabilities :: Maybe (Bool |? DocumentFormattingOptions)
_documentFormattingProvider       = forall {t :: MessageKind} {m :: Method 'ClientToServer t} {b}.
SClientMethod @t m -> Maybe (Bool |? b)
supportedBool SMethod @'ClientToServer @'Request 'Method_TextDocumentFormatting
SMethod_TextDocumentFormatting
    , $sel:_documentRangeFormattingProvider:ServerCapabilities :: Maybe (Bool |? DocumentRangeFormattingOptions)
_documentRangeFormattingProvider  = forall {t :: MessageKind} {m :: Method 'ClientToServer t} {b}.
SClientMethod @t m -> Maybe (Bool |? b)
supportedBool SMethod
  @'ClientToServer @'Request 'Method_TextDocumentRangeFormatting
SMethod_TextDocumentRangeFormatting
    , $sel:_documentOnTypeFormattingProvider:ServerCapabilities :: Maybe DocumentOnTypeFormattingOptions
_documentOnTypeFormattingProvider = Maybe DocumentOnTypeFormattingOptions
documentOnTypeFormattingProvider
    , $sel:_renameProvider:ServerCapabilities :: Maybe (Bool |? RenameOptions)
_renameProvider                   = Maybe (Bool |? RenameOptions)
renameProvider
    , $sel:_documentLinkProvider:ServerCapabilities :: Maybe DocumentLinkOptions
_documentLinkProvider             = forall {t :: MessageKind} {m :: Method 'ClientToServer t} {a}.
SClientMethod @t m -> a -> Maybe a
supported' SMethod @'ClientToServer @'Request 'Method_TextDocumentDocumentLink
SMethod_TextDocumentDocumentLink forall a b. (a -> b) -> a -> b
$ Maybe Bool -> Maybe Bool -> DocumentLinkOptions
DocumentLinkOptions
                                              (forall a. a -> Maybe a
Just Bool
False)
                                              (forall {t :: MessageKind} (m :: Method 'ClientToServer t).
SClientMethod @t m -> Maybe Bool
supported SMethod @'ClientToServer @'Request 'Method_DocumentLinkResolve
SMethod_DocumentLinkResolve)
    , $sel:_colorProvider:ServerCapabilities :: Maybe
  (Bool
   |? (DocumentColorOptions |? DocumentColorRegistrationOptions))
_colorProvider                    = forall {t :: MessageKind} {m :: Method 'ClientToServer t} {b}.
SClientMethod @t m -> Maybe (Bool |? b)
supportedBool SMethod
  @'ClientToServer @'Request 'Method_TextDocumentDocumentColor
SMethod_TextDocumentDocumentColor
    , $sel:_foldingRangeProvider:ServerCapabilities :: Maybe
  (Bool |? (FoldingRangeOptions |? FoldingRangeRegistrationOptions))
_foldingRangeProvider             = forall {t :: MessageKind} {m :: Method 'ClientToServer t} {b}.
SClientMethod @t m -> Maybe (Bool |? b)
supportedBool SMethod @'ClientToServer @'Request 'Method_TextDocumentFoldingRange
SMethod_TextDocumentFoldingRange
    , $sel:_executeCommandProvider:ServerCapabilities :: Maybe ExecuteCommandOptions
_executeCommandProvider           = Maybe ExecuteCommandOptions
executeCommandProvider
    , $sel:_selectionRangeProvider:ServerCapabilities :: Maybe
  (Bool
   |? (SelectionRangeOptions |? SelectionRangeRegistrationOptions))
_selectionRangeProvider           = forall {t :: MessageKind} {m :: Method 'ClientToServer t} {b}.
SClientMethod @t m -> Maybe (Bool |? b)
supportedBool SMethod
  @'ClientToServer @'Request 'Method_TextDocumentSelectionRange
SMethod_TextDocumentSelectionRange
    , $sel:_callHierarchyProvider:ServerCapabilities :: Maybe
  (Bool
   |? (CallHierarchyOptions |? CallHierarchyRegistrationOptions))
_callHierarchyProvider            = forall {t :: MessageKind} {m :: Method 'ClientToServer t} {b}.
SClientMethod @t m -> Maybe (Bool |? b)
supportedBool SMethod
  @'ClientToServer @'Request 'Method_TextDocumentPrepareCallHierarchy
SMethod_TextDocumentPrepareCallHierarchy
    , $sel:_semanticTokensProvider:ServerCapabilities :: Maybe (SemanticTokensOptions |? SemanticTokensRegistrationOptions)
_semanticTokensProvider           = forall {b}. Maybe (SemanticTokensOptions |? b)
semanticTokensProvider
    , $sel:_workspaceSymbolProvider:ServerCapabilities :: Maybe (Bool |? WorkspaceSymbolOptions)
_workspaceSymbolProvider          = forall {t :: MessageKind} {m :: Method 'ClientToServer t} {b}.
SClientMethod @t m -> Maybe (Bool |? b)
supportedBool SMethod @'ClientToServer @'Request 'Method_WorkspaceSymbol
SMethod_WorkspaceSymbol
    , $sel:_workspace:ServerCapabilities :: Maybe
  (Rec
     ((.+)
        @(*)
        ((.==)
           @(*) "workspaceFolders" (Maybe WorkspaceFoldersServerCapabilities))
        ((.+)
           @(*)
           ((.==) @(*) "fileOperations" (Maybe FileOperationOptions))
           (Empty @(*)))))
_workspace                        = forall a. a -> Maybe a
Just forall {a}.
Rec
  ('R
     @(*)
     ((':)
        @(LT (*))
        ((':->) @(*) "fileOperations" (Maybe a))
        ((':)
           @(LT (*))
           ((':->)
              @(*) "workspaceFolders" (Maybe WorkspaceFoldersServerCapabilities))
           ('[] @(LT (*))))))
workspace
    -- TODO: Add something for experimental
    , $sel:_experimental:ServerCapabilities :: Maybe Value
_experimental                     = forall a. Maybe a
Nothing :: Maybe Value
    -- TODO
    , $sel:_positionEncoding:ServerCapabilities :: Maybe PositionEncodingKind
_positionEncoding  = forall a. Maybe a
Nothing
    , $sel:_notebookDocumentSync:ServerCapabilities :: Maybe
  (NotebookDocumentSyncOptions
   |? NotebookDocumentSyncRegistrationOptions)
_notebookDocumentSync  = forall a. Maybe a
Nothing
    , $sel:_linkedEditingRangeProvider:ServerCapabilities :: Maybe
  (Bool
   |? (LinkedEditingRangeOptions
       |? LinkedEditingRangeRegistrationOptions))
_linkedEditingRangeProvider  = forall a. Maybe a
Nothing
    , $sel:_monikerProvider:ServerCapabilities :: Maybe (Bool |? (MonikerOptions |? MonikerRegistrationOptions))
_monikerProvider  = forall a. Maybe a
Nothing
    , $sel:_typeHierarchyProvider:ServerCapabilities :: Maybe
  (Bool
   |? (TypeHierarchyOptions |? TypeHierarchyRegistrationOptions))
_typeHierarchyProvider  = forall a. Maybe a
Nothing
    , $sel:_inlineValueProvider:ServerCapabilities :: Maybe
  (Bool |? (InlineValueOptions |? InlineValueRegistrationOptions))
_inlineValueProvider  = forall a. Maybe a
Nothing
    , $sel:_inlayHintProvider:ServerCapabilities :: Maybe (Bool |? (InlayHintOptions |? InlayHintRegistrationOptions))
_inlayHintProvider  = forall a. Maybe a
Nothing
    , $sel:_diagnosticProvider:ServerCapabilities :: Maybe (DiagnosticOptions |? DiagnosticRegistrationOptions)
_diagnosticProvider  = forall a. Maybe a
Nothing
    }
  where

    -- | For when we just return a simple @true@/@false@ to indicate if we
    -- support the capability
    supportedBool :: SClientMethod @t m -> Maybe (Bool |? b)
supportedBool = forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> a |? b
InL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {t :: MessageKind} (m :: Method 'ClientToServer t).
SClientMethod @t m -> Bool
supported_b

    supported' :: SClientMethod @t m -> a -> Maybe a
supported' SClientMethod @t m
m a
b
      | forall {t :: MessageKind} (m :: Method 'ClientToServer t).
SClientMethod @t m -> Bool
supported_b SClientMethod @t m
m = forall a. a -> Maybe a
Just a
b
      | Bool
otherwise = forall a. Maybe a
Nothing

    supported :: forall m. SClientMethod m -> Maybe Bool
    supported :: forall {t :: MessageKind} (m :: Method 'ClientToServer t).
SClientMethod @t m -> Maybe Bool
supported = forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {t :: MessageKind} (m :: Method 'ClientToServer t).
SClientMethod @t m -> Bool
supported_b

    supported_b :: forall m. SClientMethod m -> Bool
    supported_b :: forall {t :: MessageKind} (m :: Method 'ClientToServer t).
SClientMethod @t m -> Bool
supported_b SClientMethod @t m
m = case forall {t :: MessageKind} (m :: Method 'ClientToServer t).
SClientMethod @t m -> ClientNotOrReq @t m
splitClientMethod SClientMethod @t m
m of
      ClientNotOrReq @t m
IsClientNot    -> forall {f1 :: MessageDirection} {t1 :: MessageKind}
       {f2 :: MessageDirection} {t2 :: MessageKind} (a :: Method f1 t1)
       (v :: Method f2 t2 -> *).
SMethod @f1 @t1 a -> SMethodMap @f2 @t2 v -> Bool
SMethodMap.member SClientMethod @t m
m forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
Handlers m
-> SMethodMap
     @'ClientToServer
     @'Notification
     (ClientMessageHandler m 'Notification)
notHandlers Handlers m
h
      ClientNotOrReq @t m
IsClientReq    -> forall {f1 :: MessageDirection} {t1 :: MessageKind}
       {f2 :: MessageDirection} {t2 :: MessageKind} (a :: Method f1 t1)
       (v :: Method f2 t2 -> *).
SMethod @f1 @t1 a -> SMethodMap @f2 @t2 v -> Bool
SMethodMap.member SClientMethod @t m
m forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
Handlers m
-> SMethodMap
     @'ClientToServer @'Request (ClientMessageHandler m 'Request)
reqHandlers Handlers m
h
      ClientNotOrReq @t m
IsClientEither -> forall a. HasCallStack => String -> a
error String
"capabilities depend on custom method"

    singleton :: a -> [a]
    singleton :: forall a. a -> [a]
singleton a
x = [a
x]

    completionProvider :: Maybe CompletionOptions
completionProvider
      | forall {t :: MessageKind} (m :: Method 'ClientToServer t).
SClientMethod @t m -> Bool
supported_b SMethod @'ClientToServer @'Request 'Method_TextDocumentCompletion
SMethod_TextDocumentCompletion = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
          CompletionOptions {
            $sel:_triggerCharacters:CompletionOptions :: Maybe [Text]
_triggerCharacters=forall a b. (a -> b) -> [a] -> [b]
map Char -> Text
T.singleton forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Options -> Maybe String
optCompletionTriggerCharacters Options
o
            , $sel:_allCommitCharacters:CompletionOptions :: Maybe [Text]
_allCommitCharacters=forall a b. (a -> b) -> [a] -> [b]
map Char -> Text
T.singleton forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Options -> Maybe String
optCompletionAllCommitCharacters Options
o
            , $sel:_resolveProvider:CompletionOptions :: Maybe Bool
_resolveProvider=forall {t :: MessageKind} (m :: Method 'ClientToServer t).
SClientMethod @t m -> Maybe Bool
supported SMethod @'ClientToServer @'Request 'Method_CompletionItemResolve
SMethod_CompletionItemResolve
            , $sel:_completionItem:CompletionOptions :: Maybe
  (Rec
     ((.+)
        @(*) ((.==) @(*) "labelDetailsSupport" (Maybe Bool)) (Empty @(*))))
_completionItem=forall a. Maybe a
Nothing
            , $sel:_workDoneProgress:CompletionOptions :: Maybe Bool
_workDoneProgress=forall a. Maybe a
Nothing
            }
      | Bool
otherwise = forall a. Maybe a
Nothing

    clientSupportsCodeActionKinds :: Bool
clientSupportsCodeActionKinds = forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$
      ClientCapabilities
clientCaps forall s a. s -> Getting (First a) s a -> Maybe a
^? forall s a. HasTextDocument s a => Lens' s a
L.textDocument forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasCodeAction s a => Lens' s a
L.codeAction forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasCodeActionLiteralSupport s a => Lens' s a
L.codeActionLiteralSupport forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just

    codeActionProvider :: Maybe (Bool |? CodeActionOptions)
codeActionProvider
      | forall {t :: MessageKind} (m :: Method 'ClientToServer t).
SClientMethod @t m -> Bool
supported_b SMethod @'ClientToServer @'Request 'Method_TextDocumentCodeAction
SMethod_TextDocumentCodeAction = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. b -> a |? b
InR forall a b. (a -> b) -> a -> b
$
          CodeActionOptions {
            $sel:_workDoneProgress:CodeActionOptions :: Maybe Bool
_workDoneProgress = forall a. Maybe a
Nothing
           , $sel:_codeActionKinds:CodeActionOptions :: Maybe [CodeActionKind]
_codeActionKinds = Maybe [CodeActionKind] -> Maybe [CodeActionKind]
codeActionKinds (Options -> Maybe [CodeActionKind]
optCodeActionKinds Options
o)
           , $sel:_resolveProvider:CodeActionOptions :: Maybe Bool
_resolveProvider = forall {t :: MessageKind} (m :: Method 'ClientToServer t).
SClientMethod @t m -> Maybe Bool
supported SMethod @'ClientToServer @'Request 'Method_CodeActionResolve
SMethod_CodeActionResolve
          }
      | Bool
otherwise = forall a. a -> Maybe a
Just (forall a b. a -> a |? b
InL Bool
False)

    codeActionKinds :: Maybe [CodeActionKind] -> Maybe [CodeActionKind]
codeActionKinds (Just [CodeActionKind]
ks)
      | Bool
clientSupportsCodeActionKinds = forall a. a -> Maybe a
Just [CodeActionKind]
ks
    codeActionKinds Maybe [CodeActionKind]
_ = forall a. Maybe a
Nothing

    signatureHelpProvider :: Maybe SignatureHelpOptions
signatureHelpProvider
      | forall {t :: MessageKind} (m :: Method 'ClientToServer t).
SClientMethod @t m -> Bool
supported_b SMethod
  @'ClientToServer @'Request 'Method_TextDocumentSignatureHelp
SMethod_TextDocumentSignatureHelp = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
          Maybe Bool -> Maybe [Text] -> Maybe [Text] -> SignatureHelpOptions
SignatureHelpOptions
            forall a. Maybe a
Nothing
            (forall a b. (a -> b) -> [a] -> [b]
map Char -> Text
T.singleton forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Options -> Maybe String
optSignatureHelpTriggerCharacters Options
o)
            (forall a b. (a -> b) -> [a] -> [b]
map Char -> Text
T.singleton forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Options -> Maybe String
optSignatureHelpRetriggerCharacters Options
o)
      | Bool
otherwise = forall a. Maybe a
Nothing

    documentOnTypeFormattingProvider :: Maybe DocumentOnTypeFormattingOptions
documentOnTypeFormattingProvider
      | forall {t :: MessageKind} (m :: Method 'ClientToServer t).
SClientMethod @t m -> Bool
supported_b SMethod
  @'ClientToServer @'Request 'Method_TextDocumentOnTypeFormatting
SMethod_TextDocumentOnTypeFormatting
      , Just (Char
first :| String
rest) <- Options -> Maybe (NonEmpty Char)
optDocumentOnTypeFormattingTriggerCharacters Options
o = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
          Text -> Maybe [Text] -> DocumentOnTypeFormattingOptions
DocumentOnTypeFormattingOptions (String -> Text
T.pack [Char
first]) (forall a. a -> Maybe a
Just (forall a b. (a -> b) -> [a] -> [b]
map (String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> [a]
singleton) String
rest))
      | forall {t :: MessageKind} (m :: Method 'ClientToServer t).
SClientMethod @t m -> Bool
supported_b SMethod
  @'ClientToServer @'Request 'Method_TextDocumentOnTypeFormatting
SMethod_TextDocumentOnTypeFormatting
      , Maybe (NonEmpty Char)
Nothing <- Options -> Maybe (NonEmpty Char)
optDocumentOnTypeFormattingTriggerCharacters Options
o =
          forall a. HasCallStack => String -> a
error String
"documentOnTypeFormattingTriggerCharacters needs to be set if a documentOnTypeFormattingHandler is set"
      | Bool
otherwise = forall a. Maybe a
Nothing

    executeCommandProvider :: Maybe ExecuteCommandOptions
executeCommandProvider
      | forall {t :: MessageKind} (m :: Method 'ClientToServer t).
SClientMethod @t m -> Bool
supported_b SMethod @'ClientToServer @'Request 'Method_WorkspaceExecuteCommand
SMethod_WorkspaceExecuteCommand
      , Just [Text]
cmds <- Options -> Maybe [Text]
optExecuteCommandCommands Options
o = forall a. a -> Maybe a
Just (Maybe Bool -> [Text] -> ExecuteCommandOptions
ExecuteCommandOptions forall a. Maybe a
Nothing [Text]
cmds)
      | forall {t :: MessageKind} (m :: Method 'ClientToServer t).
SClientMethod @t m -> Bool
supported_b SMethod @'ClientToServer @'Request 'Method_WorkspaceExecuteCommand
SMethod_WorkspaceExecuteCommand
      , Maybe [Text]
Nothing <- Options -> Maybe [Text]
optExecuteCommandCommands Options
o =
          forall a. HasCallStack => String -> a
error String
"executeCommandCommands needs to be set if a executeCommandHandler is set"
      | Bool
otherwise = forall a. Maybe a
Nothing

    clientSupportsPrepareRename :: Bool
clientSupportsPrepareRename = forall a. a -> Maybe a -> a
fromMaybe Bool
False forall a b. (a -> b) -> a -> b
$
      ClientCapabilities
clientCaps forall s a. s -> Getting (First a) s a -> Maybe a
^? forall s a. HasTextDocument s a => Lens' s a
L.textDocument forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasRename s a => Lens' s a
L.rename forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasPrepareSupport s a => Lens' s a
L.prepareSupport forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just

    renameProvider :: Maybe (Bool |? RenameOptions)
renameProvider
      | Bool
clientSupportsPrepareRename
      , forall {t :: MessageKind} (m :: Method 'ClientToServer t).
SClientMethod @t m -> Bool
supported_b SMethod @'ClientToServer @'Request 'Method_TextDocumentRename
SMethod_TextDocumentRename
      , forall {t :: MessageKind} (m :: Method 'ClientToServer t).
SClientMethod @t m -> Bool
supported_b SMethod
  @'ClientToServer @'Request 'Method_TextDocumentPrepareRename
SMethod_TextDocumentPrepareRename = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
          forall a b. b -> a |? b
InR forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Bool -> Maybe Bool -> RenameOptions
RenameOptions forall a. Maybe a
Nothing forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Bool
True
      | forall {t :: MessageKind} (m :: Method 'ClientToServer t).
SClientMethod @t m -> Bool
supported_b SMethod @'ClientToServer @'Request 'Method_TextDocumentRename
SMethod_TextDocumentRename = forall a. a -> Maybe a
Just (forall a b. a -> a |? b
InL Bool
True)
      | Bool
otherwise = forall a. a -> Maybe a
Just (forall a b. a -> a |? b
InL Bool
False)

    -- Always provide the default legend
    -- TODO: allow user-provided legend via 'Options', or at least user-provided types
    semanticTokensProvider :: Maybe (SemanticTokensOptions |? b)
semanticTokensProvider = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. a -> a |? b
InL forall a b. (a -> b) -> a -> b
$ Maybe Bool
-> SemanticTokensLegend
-> Maybe (Bool |? Rec (Empty @(*)))
-> Maybe
     (Bool
      |? Rec ((.+) @(*) ((.==) @(*) "delta" (Maybe Bool)) (Empty @(*))))
-> SemanticTokensOptions
SemanticTokensOptions forall a. Maybe a
Nothing SemanticTokensLegend
defaultSemanticTokensLegend forall {b}. Maybe (Bool |? b)
semanticTokenRangeProvider forall {a}.
Maybe
  (a
   |? Rec
        ('R
           @(*)
           ((':)
              @(LT (*)) ((':->) @(*) "delta" (Maybe Bool)) ('[] @(LT (*))))))
semanticTokenFullProvider
    semanticTokenRangeProvider :: Maybe (Bool |? b)
semanticTokenRangeProvider
      | forall {t :: MessageKind} (m :: Method 'ClientToServer t).
SClientMethod @t m -> Bool
supported_b SMethod
  @'ClientToServer @'Request 'Method_TextDocumentSemanticTokensRange
SMethod_TextDocumentSemanticTokensRange = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. a -> a |? b
InL Bool
True
      | Bool
otherwise = forall a. Maybe a
Nothing
    semanticTokenFullProvider :: Maybe
  (a
   |? Rec
        ('R
           @(*)
           ((':)
              @(LT (*)) ((':->) @(*) "delta" (Maybe Bool)) ('[] @(LT (*))))))
semanticTokenFullProvider
      | forall {t :: MessageKind} (m :: Method 'ClientToServer t).
SClientMethod @t m -> Bool
supported_b SMethod
  @'ClientToServer @'Request 'Method_TextDocumentSemanticTokensFull
SMethod_TextDocumentSemanticTokensFull = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. b -> a |? b
InR forall a b. (a -> b) -> a -> b
$ forall a. IsLabel "delta" a => a
#delta forall (l :: Symbol) a.
KnownSymbol l =>
Label l -> a -> Rec ((.==) @(*) l a)
.== forall {t :: MessageKind} (m :: Method 'ClientToServer t).
SClientMethod @t m -> Maybe Bool
supported SMethod
  @'ClientToServer
  @'Request
  'Method_TextDocumentSemanticTokensFullDelta
SMethod_TextDocumentSemanticTokensFullDelta
      | Bool
otherwise = forall a. Maybe a
Nothing

    sync :: Maybe (TextDocumentSyncOptions |? TextDocumentSyncKind)
sync = case Options -> Maybe TextDocumentSyncOptions
optTextDocumentSync Options
o of
            Just TextDocumentSyncOptions
x  -> forall a. a -> Maybe a
Just (forall a b. a -> a |? b
InL TextDocumentSyncOptions
x)
            Maybe TextDocumentSyncOptions
Nothing -> forall a. Maybe a
Nothing

    workspace :: Rec
  ((.+)
     @(*)
     ('R
        @(*)
        ((':)
           @(LT (*))
           ((':->)
              @(*) "workspaceFolders" (Maybe WorkspaceFoldersServerCapabilities))
           ('[] @(LT (*)))))
     ('R
        @(*)
        ((':)
           @(LT (*))
           ((':->) @(*) "fileOperations" (Maybe a))
           ('[] @(LT (*))))))
workspace = forall a. IsLabel "workspaceFolders" a => a
#workspaceFolders forall (l :: Symbol) a.
KnownSymbol l =>
Label l -> a -> Rec ((.==) @(*) l a)
.== Maybe WorkspaceFoldersServerCapabilities
workspaceFolder forall (l :: Row (*)) (r :: Row (*)).
FreeForall @(*) l =>
Rec l -> Rec r -> Rec ((.+) @(*) l r)
.+ forall a. IsLabel "fileOperations" a => a
#fileOperations forall (l :: Symbol) a.
KnownSymbol l =>
Label l -> a -> Rec ((.==) @(*) l a)
.== forall a. Maybe a
Nothing
    workspaceFolder :: Maybe WorkspaceFoldersServerCapabilities
workspaceFolder = forall {t :: MessageKind} {m :: Method 'ClientToServer t} {a}.
SClientMethod @t m -> a -> Maybe a
supported' SMethod
  @'ClientToServer
  @'Notification
  'Method_WorkspaceDidChangeWorkspaceFolders
SMethod_WorkspaceDidChangeWorkspaceFolders forall a b. (a -> b) -> a -> b
$
        -- sign up to receive notifications
        Maybe Bool
-> Maybe (Text |? Bool) -> WorkspaceFoldersServerCapabilities
WorkspaceFoldersServerCapabilities (forall a. a -> Maybe a
Just Bool
True) (forall a. a -> Maybe a
Just (forall a b. b -> a |? b
InR Bool
True))

-- | Invokes the registered dynamic or static handlers for the given message and
-- method, as well as doing some bookkeeping.
handle :: (m ~ LspM config) => LogAction m (WithSeverity LspProcessingLog) -> SClientMethod meth -> TClientMessage meth -> m ()
handle :: forall {t :: MessageKind} (m :: * -> *) config
       (meth :: Method 'ClientToServer t).
((m :: (* -> *)) ~ (LspM config :: (* -> *))) =>
LogAction m (WithSeverity LspProcessingLog)
-> SClientMethod @t meth -> TClientMessage @t meth -> m ()
handle LogAction m (WithSeverity LspProcessingLog)
logger SClientMethod @t meth
m TClientMessage @t meth
msg =
  case SClientMethod @t meth
m of
    SClientMethod @t meth
SMethod_WorkspaceDidChangeWorkspaceFolders -> forall (m :: * -> *) (t :: MessageKind)
       (meth :: Method 'ClientToServer t) config.
((m :: (* -> *)) ~ (LspM config :: (* -> *))) =>
LogAction m (WithSeverity LspProcessingLog)
-> Maybe (TClientMessage @t meth -> m ())
-> SClientMethod @t meth
-> TClientMessage @t meth
-> m ()
handle' LogAction m (WithSeverity LspProcessingLog)
logger (forall a. a -> Maybe a
Just forall config.
TMessage
  @'ClientToServer
  @'Notification
  'Method_WorkspaceDidChangeWorkspaceFolders
-> LspM config ()
updateWorkspaceFolders) SClientMethod @t meth
m TClientMessage @t meth
msg
    SClientMethod @t meth
SMethod_WorkspaceDidChangeConfiguration    -> forall (m :: * -> *) (t :: MessageKind)
       (meth :: Method 'ClientToServer t) config.
((m :: (* -> *)) ~ (LspM config :: (* -> *))) =>
LogAction m (WithSeverity LspProcessingLog)
-> Maybe (TClientMessage @t meth -> m ())
-> SClientMethod @t meth
-> TClientMessage @t meth
-> m ()
handle' LogAction m (WithSeverity LspProcessingLog)
logger (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) config.
((m :: (* -> *)) ~ (LspM config :: (* -> *))) =>
LogAction m (WithSeverity LspProcessingLog)
-> TMessage
     @'ClientToServer
     @'Notification
     'Method_WorkspaceDidChangeConfiguration
-> m ()
handleDidChangeConfiguration LogAction m (WithSeverity LspProcessingLog)
logger) SClientMethod @t meth
m TClientMessage @t meth
msg
    -- See Note [LSP configuration]
    SClientMethod @t meth
SMethod_Initialized                        -> forall (m :: * -> *) (t :: MessageKind)
       (meth :: Method 'ClientToServer t) config.
((m :: (* -> *)) ~ (LspM config :: (* -> *))) =>
LogAction m (WithSeverity LspProcessingLog)
-> Maybe (TClientMessage @t meth -> m ())
-> SClientMethod @t meth
-> TClientMessage @t meth
-> m ()
handle' LogAction m (WithSeverity LspProcessingLog)
logger (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ \TClientMessage @t meth
_ -> forall (m :: * -> *) config.
((m :: (* -> *)) ~ (LspM config :: (* -> *))) =>
LogAction m (WithSeverity LspCoreLog) -> m ()
requestConfigUpdate (forall a b (m :: * -> *).
(a -> b) -> LogAction m b -> LogAction m a
cmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LspCoreLog -> LspProcessingLog
LspCore) LogAction m (WithSeverity LspProcessingLog)
logger)) SClientMethod @t meth
m TClientMessage @t meth
msg
    SClientMethod @t meth
SMethod_TextDocumentDidOpen                -> forall (m :: * -> *) (t :: MessageKind)
       (meth :: Method 'ClientToServer t) config.
((m :: (* -> *)) ~ (LspM config :: (* -> *))) =>
LogAction m (WithSeverity LspProcessingLog)
-> Maybe (TClientMessage @t meth -> m ())
-> SClientMethod @t meth
-> TClientMessage @t meth
-> m ()
handle' LogAction m (WithSeverity LspProcessingLog)
logger (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (n :: * -> *) a config.
((m :: (* -> *)) ~ (LspM config :: (* -> *)),
 (n :: (* -> *))
 ~ (WriterT [WithSeverity VfsLog] (State VFS) :: (* -> *))) =>
LogAction m (WithSeverity LspProcessingLog)
-> (LogAction n (WithSeverity VfsLog) -> a -> n ()) -> a -> m ()
vfsFunc LogAction m (WithSeverity LspProcessingLog)
logger forall (m :: * -> *).
MonadState VFS m =>
LogAction m (WithSeverity VfsLog)
-> TMessage
     @'ClientToServer @'Notification 'Method_TextDocumentDidOpen
-> m ()
openVFS) SClientMethod @t meth
m TClientMessage @t meth
msg
    SClientMethod @t meth
SMethod_TextDocumentDidChange              -> forall (m :: * -> *) (t :: MessageKind)
       (meth :: Method 'ClientToServer t) config.
((m :: (* -> *)) ~ (LspM config :: (* -> *))) =>
LogAction m (WithSeverity LspProcessingLog)
-> Maybe (TClientMessage @t meth -> m ())
-> SClientMethod @t meth
-> TClientMessage @t meth
-> m ()
handle' LogAction m (WithSeverity LspProcessingLog)
logger (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (n :: * -> *) a config.
((m :: (* -> *)) ~ (LspM config :: (* -> *)),
 (n :: (* -> *))
 ~ (WriterT [WithSeverity VfsLog] (State VFS) :: (* -> *))) =>
LogAction m (WithSeverity LspProcessingLog)
-> (LogAction n (WithSeverity VfsLog) -> a -> n ()) -> a -> m ()
vfsFunc LogAction m (WithSeverity LspProcessingLog)
logger forall (m :: * -> *).
MonadState VFS m =>
LogAction m (WithSeverity VfsLog)
-> TMessage
     @'ClientToServer @'Notification 'Method_TextDocumentDidChange
-> m ()
changeFromClientVFS) SClientMethod @t meth
m TClientMessage @t meth
msg
    SClientMethod @t meth
SMethod_TextDocumentDidClose               -> forall (m :: * -> *) (t :: MessageKind)
       (meth :: Method 'ClientToServer t) config.
((m :: (* -> *)) ~ (LspM config :: (* -> *))) =>
LogAction m (WithSeverity LspProcessingLog)
-> Maybe (TClientMessage @t meth -> m ())
-> SClientMethod @t meth
-> TClientMessage @t meth
-> m ()
handle' LogAction m (WithSeverity LspProcessingLog)
logger (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (n :: * -> *) a config.
((m :: (* -> *)) ~ (LspM config :: (* -> *)),
 (n :: (* -> *))
 ~ (WriterT [WithSeverity VfsLog] (State VFS) :: (* -> *))) =>
LogAction m (WithSeverity LspProcessingLog)
-> (LogAction n (WithSeverity VfsLog) -> a -> n ()) -> a -> m ()
vfsFunc LogAction m (WithSeverity LspProcessingLog)
logger forall (m :: * -> *).
MonadState VFS m =>
LogAction m (WithSeverity VfsLog)
-> TMessage
     @'ClientToServer @'Notification 'Method_TextDocumentDidClose
-> m ()
closeVFS) SClientMethod @t meth
m TClientMessage @t meth
msg
    SClientMethod @t meth
SMethod_WindowWorkDoneProgressCancel       -> forall (m :: * -> *) (t :: MessageKind)
       (meth :: Method 'ClientToServer t) config.
((m :: (* -> *)) ~ (LspM config :: (* -> *))) =>
LogAction m (WithSeverity LspProcessingLog)
-> Maybe (TClientMessage @t meth -> m ())
-> SClientMethod @t meth
-> TClientMessage @t meth
-> m ()
handle' LogAction m (WithSeverity LspProcessingLog)
logger (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) config.
((m :: (* -> *)) ~ (LspM config :: (* -> *))) =>
LogAction m (WithSeverity LspProcessingLog)
-> TMessage
     @'ClientToServer
     @'Notification
     'Method_WindowWorkDoneProgressCancel
-> m ()
progressCancelHandler LogAction m (WithSeverity LspProcessingLog)
logger) SClientMethod @t meth
m TClientMessage @t meth
msg
    SClientMethod @t meth
_ -> forall (m :: * -> *) (t :: MessageKind)
       (meth :: Method 'ClientToServer t) config.
((m :: (* -> *)) ~ (LspM config :: (* -> *))) =>
LogAction m (WithSeverity LspProcessingLog)
-> Maybe (TClientMessage @t meth -> m ())
-> SClientMethod @t meth
-> TClientMessage @t meth
-> m ()
handle' LogAction m (WithSeverity LspProcessingLog)
logger forall a. Maybe a
Nothing SClientMethod @t meth
m TClientMessage @t meth
msg


handle' :: forall m t (meth :: Method ClientToServer t) config
        . (m ~ LspM config)
        => LogAction m (WithSeverity LspProcessingLog)
        -> Maybe (TClientMessage meth -> m ())
           -- ^ An action to be run before invoking the handler, used for
           -- bookkeeping stuff like the vfs etc.
        -> SClientMethod meth
        -> TClientMessage meth
        -> m ()
handle' :: forall (m :: * -> *) (t :: MessageKind)
       (meth :: Method 'ClientToServer t) config.
((m :: (* -> *)) ~ (LspM config :: (* -> *))) =>
LogAction m (WithSeverity LspProcessingLog)
-> Maybe (TClientMessage @t meth -> m ())
-> SClientMethod @t meth
-> TClientMessage @t meth
-> m ()
handle' LogAction m (WithSeverity LspProcessingLog)
logger Maybe (TClientMessage @t meth -> m ())
mAction SClientMethod @t meth
m TClientMessage @t meth
msg = do
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) (\TClientMessage @t meth -> m ()
f -> TClientMessage @t meth -> m ()
f TClientMessage @t meth
msg) Maybe (TClientMessage @t meth -> m ())
mAction

  RegistrationMap 'Request
dynReqHandlers <- forall config (m :: * -> *) a.
MonadLsp config m =>
(LanguageContextState config -> TVar a) -> m a
getsState forall config.
LanguageContextState config -> TVar (RegistrationMap 'Request)
resRegistrationsReq
  RegistrationMap 'Notification
dynNotHandlers <- forall config (m :: * -> *) a.
MonadLsp config m =>
(LanguageContextState config -> TVar a) -> m a
getsState forall config.
LanguageContextState config -> TVar (RegistrationMap 'Notification)
resRegistrationsNot

  LanguageContextEnv config
env <- forall config (m :: * -> *).
MonadLsp config m =>
m (LanguageContextEnv config)
getLspEnv
  let Handlers{SMethodMap
  @'ClientToServer @'Request (ClientMessageHandler IO 'Request)
reqHandlers :: SMethodMap
  @'ClientToServer @'Request (ClientMessageHandler IO 'Request)
reqHandlers :: forall (m :: * -> *).
Handlers m
-> SMethodMap
     @'ClientToServer @'Request (ClientMessageHandler m 'Request)
reqHandlers, SMethodMap
  @'ClientToServer
  @'Notification
  (ClientMessageHandler IO 'Notification)
notHandlers :: SMethodMap
  @'ClientToServer
  @'Notification
  (ClientMessageHandler IO 'Notification)
notHandlers :: forall (m :: * -> *).
Handlers m
-> SMethodMap
     @'ClientToServer
     @'Notification
     (ClientMessageHandler m 'Notification)
notHandlers} = forall config. LanguageContextEnv config -> Handlers IO
resHandlers LanguageContextEnv config
env

  let mkRspCb :: TRequestMessage (m1 :: Method ClientToServer Request) -> Either ResponseError (MessageResult m1) -> IO ()
      mkRspCb :: forall (m1 :: Method 'ClientToServer 'Request).
TRequestMessage @'ClientToServer m1
-> Either
     ResponseError (MessageResult @'ClientToServer @'Request m1)
-> IO ()
mkRspCb TRequestMessage @'ClientToServer m1
req (Left  ResponseError
err) = forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
runLspT LanguageContextEnv config
env forall a b. (a -> b) -> a -> b
$ forall config (m :: * -> *).
MonadLsp config m =>
FromServerMessage -> m ()
sendToClient forall a b. (a -> b) -> a -> b
$
        forall (m :: Method 'ClientToServer 'Request)
       (a :: Method 'ClientToServer 'Request -> *).
a m -> TResponseMessage @'ClientToServer m -> FromServerMessage' a
FromServerRsp (TRequestMessage @'ClientToServer m1
req forall s a. s -> Getting a s a -> a
^. forall s a. HasMethod s a => Lens' s a
L.method) forall a b. (a -> b) -> a -> b
$ forall (f :: MessageDirection) (m :: Method f 'Request).
Text
-> Maybe (LspId @f m)
-> Either ResponseError (MessageResult @f @'Request m)
-> TResponseMessage @f m
TResponseMessage Text
"2.0" (forall a. a -> Maybe a
Just (TRequestMessage @'ClientToServer m1
req forall s a. s -> Getting a s a -> a
^. forall s a. HasId s a => Lens' s a
L.id)) (forall a b. a -> Either a b
Left ResponseError
err)
      mkRspCb TRequestMessage @'ClientToServer m1
req (Right MessageResult @'ClientToServer @'Request m1
rsp) = forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
runLspT LanguageContextEnv config
env forall a b. (a -> b) -> a -> b
$ forall config (m :: * -> *).
MonadLsp config m =>
FromServerMessage -> m ()
sendToClient forall a b. (a -> b) -> a -> b
$
        forall (m :: Method 'ClientToServer 'Request)
       (a :: Method 'ClientToServer 'Request -> *).
a m -> TResponseMessage @'ClientToServer m -> FromServerMessage' a
FromServerRsp (TRequestMessage @'ClientToServer m1
req forall s a. s -> Getting a s a -> a
^. forall s a. HasMethod s a => Lens' s a
L.method) forall a b. (a -> b) -> a -> b
$ forall (f :: MessageDirection) (m :: Method f 'Request).
Text
-> Maybe (LspId @f m)
-> Either ResponseError (MessageResult @f @'Request m)
-> TResponseMessage @f m
TResponseMessage Text
"2.0" (forall a. a -> Maybe a
Just (TRequestMessage @'ClientToServer m1
req forall s a. s -> Getting a s a -> a
^. forall s a. HasId s a => Lens' s a
L.id)) (forall a b. b -> Either a b
Right MessageResult @'ClientToServer @'Request m1
rsp)

  case forall {t :: MessageKind} (m :: Method 'ClientToServer t).
SClientMethod @t m -> ClientNotOrReq @t m
splitClientMethod SClientMethod @t meth
m of
    ClientNotOrReq @t meth
IsClientNot -> case RegistrationMap t
-> SMethodMap @'ClientToServer @t (ClientMessageHandler IO t)
-> Maybe (Handler @'ClientToServer @t IO meth)
pickHandler RegistrationMap 'Notification
dynNotHandlers SMethodMap
  @'ClientToServer
  @'Notification
  (ClientMessageHandler IO 'Notification)
notHandlers of
      Just Handler @'ClientToServer @t IO meth
h -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handler @'ClientToServer @t IO meth
h TClientMessage @t meth
msg
      Maybe (Handler @'ClientToServer @t IO meth)
Nothing
        | SClientMethod @t meth
SMethod_Exit <- SClientMethod @t meth
m -> forall (m :: * -> *).
MonadIO m =>
LogAction m (WithSeverity LspProcessingLog)
-> Handler @'ClientToServer @'Notification m 'Method_Exit
exitNotificationHandler LogAction m (WithSeverity LspProcessingLog)
logger TClientMessage @t meth
msg
        | Bool
otherwise -> do
            m ()
reportMissingHandler

    ClientNotOrReq @t meth
IsClientReq -> case RegistrationMap t
-> SMethodMap @'ClientToServer @t (ClientMessageHandler IO t)
-> Maybe (Handler @'ClientToServer @t IO meth)
pickHandler RegistrationMap 'Request
dynReqHandlers SMethodMap
  @'ClientToServer @'Request (ClientMessageHandler IO 'Request)
reqHandlers of
      Just Handler @'ClientToServer @t IO meth
h -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handler @'ClientToServer @t IO meth
h TClientMessage @t meth
msg (forall (m1 :: Method 'ClientToServer 'Request).
TRequestMessage @'ClientToServer m1
-> Either
     ResponseError (MessageResult @'ClientToServer @'Request m1)
-> IO ()
mkRspCb TClientMessage @t meth
msg)
      Maybe (Handler @'ClientToServer @t IO meth)
Nothing
        | SClientMethod @t meth
SMethod_Shutdown <- SClientMethod @t meth
m -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handler @'ClientToServer @'Request IO 'Method_Shutdown
shutdownRequestHandler TClientMessage @t meth
msg (forall (m1 :: Method 'ClientToServer 'Request).
TRequestMessage @'ClientToServer m1
-> Either
     ResponseError (MessageResult @'ClientToServer @'Request m1)
-> IO ()
mkRspCb TClientMessage @t meth
msg)
        | Bool
otherwise -> do
            let errorMsg :: Text
errorMsg = String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String
"lsp:no handler for: ", forall a. Show a => a -> String
show SClientMethod @t meth
m]
                err :: ResponseError
err = (LSPErrorCodes |? ErrorCodes)
-> Text -> Maybe Value -> ResponseError
ResponseError (forall a b. b -> a |? b
InR ErrorCodes
ErrorCodes_MethodNotFound) Text
errorMsg forall a. Maybe a
Nothing
            forall config (m :: * -> *).
MonadLsp config m =>
FromServerMessage -> m ()
sendToClient forall a b. (a -> b) -> a -> b
$
              forall (m :: Method 'ClientToServer 'Request)
       (a :: Method 'ClientToServer 'Request -> *).
a m -> TResponseMessage @'ClientToServer m -> FromServerMessage' a
FromServerRsp (TClientMessage @t meth
msg forall s a. s -> Getting a s a -> a
^. forall s a. HasMethod s a => Lens' s a
L.method) forall a b. (a -> b) -> a -> b
$ forall (f :: MessageDirection) (m :: Method f 'Request).
Text
-> Maybe (LspId @f m)
-> Either ResponseError (MessageResult @f @'Request m)
-> TResponseMessage @f m
TResponseMessage Text
"2.0" (forall a. a -> Maybe a
Just (TClientMessage @t meth
msg forall s a. s -> Getting a s a -> a
^. forall s a. HasId s a => Lens' s a
L.id)) (forall a b. a -> Either a b
Left ResponseError
err)

    ClientNotOrReq @t meth
IsClientEither -> case TClientMessage @t meth
msg of
      NotMess TNotificationMessage
  @'ClientToServer
  ('Method_CustomMethod @'ClientToServer @'Notification s)
noti -> case RegistrationMap t
-> SMethodMap @'ClientToServer @t (ClientMessageHandler IO t)
-> Maybe (Handler @'ClientToServer @t IO meth)
pickHandler RegistrationMap 'Notification
dynNotHandlers SMethodMap
  @'ClientToServer
  @'Notification
  (ClientMessageHandler IO 'Notification)
notHandlers of
        Just Handler @'ClientToServer @t IO meth
h  -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handler @'ClientToServer @t IO meth
h TNotificationMessage
  @'ClientToServer
  ('Method_CustomMethod @'ClientToServer @'Notification s)
noti
        Maybe (Handler @'ClientToServer @t IO meth)
Nothing -> m ()
reportMissingHandler
      ReqMess TRequestMessage
  @'ClientToServer
  ('Method_CustomMethod @'ClientToServer @'Request s)
req -> case RegistrationMap t
-> SMethodMap @'ClientToServer @t (ClientMessageHandler IO t)
-> Maybe (Handler @'ClientToServer @t IO meth)
pickHandler RegistrationMap 'Request
dynReqHandlers SMethodMap
  @'ClientToServer @'Request (ClientMessageHandler IO 'Request)
reqHandlers of
        Just Handler @'ClientToServer @t IO meth
h -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handler @'ClientToServer @t IO meth
h TRequestMessage
  @'ClientToServer
  ('Method_CustomMethod @'ClientToServer @'Request s)
req (forall (m1 :: Method 'ClientToServer 'Request).
TRequestMessage @'ClientToServer m1
-> Either
     ResponseError (MessageResult @'ClientToServer @'Request m1)
-> IO ()
mkRspCb TRequestMessage
  @'ClientToServer
  ('Method_CustomMethod @'ClientToServer @'Request s)
req)
        Maybe (Handler @'ClientToServer @t IO meth)
Nothing -> do
          let errorMsg :: Text
errorMsg = String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String
"lsp:no handler for: ", forall a. Show a => a -> String
show SClientMethod @t meth
m]
              err :: ResponseError
err = (LSPErrorCodes |? ErrorCodes)
-> Text -> Maybe Value -> ResponseError
ResponseError (forall a b. b -> a |? b
InR ErrorCodes
ErrorCodes_MethodNotFound) Text
errorMsg forall a. Maybe a
Nothing
          forall config (m :: * -> *).
MonadLsp config m =>
FromServerMessage -> m ()
sendToClient forall a b. (a -> b) -> a -> b
$
            forall (m :: Method 'ClientToServer 'Request)
       (a :: Method 'ClientToServer 'Request -> *).
a m -> TResponseMessage @'ClientToServer m -> FromServerMessage' a
FromServerRsp (TRequestMessage
  @'ClientToServer
  ('Method_CustomMethod @'ClientToServer @'Request s)
req forall s a. s -> Getting a s a -> a
^. forall s a. HasMethod s a => Lens' s a
L.method) forall a b. (a -> b) -> a -> b
$ forall (f :: MessageDirection) (m :: Method f 'Request).
Text
-> Maybe (LspId @f m)
-> Either ResponseError (MessageResult @f @'Request m)
-> TResponseMessage @f m
TResponseMessage Text
"2.0" (forall a. a -> Maybe a
Just (TRequestMessage
  @'ClientToServer
  ('Method_CustomMethod @'ClientToServer @'Request s)
req forall s a. s -> Getting a s a -> a
^. forall s a. HasId s a => Lens' s a
L.id)) (forall a b. a -> Either a b
Left ResponseError
err)
  where
    -- | Checks to see if there's a dynamic handler, and uses it in favour of the
    -- static handler, if it exists.
    pickHandler :: RegistrationMap t -> SMethodMap (ClientMessageHandler IO t) -> Maybe (Handler IO meth)
    pickHandler :: RegistrationMap t
-> SMethodMap @'ClientToServer @t (ClientMessageHandler IO t)
-> Maybe (Handler @'ClientToServer @t IO meth)
pickHandler RegistrationMap t
dynHandlerMap SMethodMap @'ClientToServer @t (ClientMessageHandler IO t)
staticHandler = case (forall {f :: MessageDirection} {t :: MessageKind} (a :: Method f t)
       (v :: Method f t -> *).
SMethod @f @t a -> SMethodMap @f @t v -> Maybe (v a)
SMethodMap.lookup SClientMethod @t meth
m RegistrationMap t
dynHandlerMap, forall {f :: MessageDirection} {t :: MessageKind} (a :: Method f t)
       (v :: Method f t -> *).
SMethod @f @t a -> SMethodMap @f @t v -> Maybe (v a)
SMethodMap.lookup SClientMethod @t meth
m SMethodMap @'ClientToServer @t (ClientMessageHandler IO t)
staticHandler) of
      (Just (P.Pair RegistrationId @t meth
_ (ClientMessageHandler Handler @'ClientToServer @t IO meth
h)), Maybe (ClientMessageHandler IO t meth)
_) -> forall a. a -> Maybe a
Just Handler @'ClientToServer @t IO meth
h
      (Maybe
  (Product
     @(Method 'ClientToServer t)
     (RegistrationId @t)
     (ClientMessageHandler IO t)
     meth)
Nothing, Just (ClientMessageHandler Handler @'ClientToServer @t IO meth
h))      -> forall a. a -> Maybe a
Just Handler @'ClientToServer @t IO meth
h
      (Maybe
  (Product
     @(Method 'ClientToServer t)
     (RegistrationId @t)
     (ClientMessageHandler IO t)
     meth)
Nothing, Maybe (ClientMessageHandler IO t meth)
Nothing)                            -> forall a. Maybe a
Nothing

    -- '$/' notifications should/could be ignored by server.
    -- Don't log errors in that case.
    -- See https://microsoft.github.io/language-server-protocol/specifications/specification-current/#-notifications-and-requests.
    reportMissingHandler :: m ()
    reportMissingHandler :: m ()
reportMissingHandler =
      let optional :: Bool
optional = SomeMethod -> Bool
isOptionalMethod (forall {f :: MessageDirection} {t :: MessageKind}
       (m :: Method f t).
SMethod @f @t m -> SomeMethod
SomeMethod SClientMethod @t meth
m)
      in LogAction m (WithSeverity LspProcessingLog)
logger forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& forall {t :: MessageKind} (m :: Method 'ClientToServer t).
Bool -> SClientMethod @t m -> LspProcessingLog
MissingHandler Bool
optional SClientMethod @t meth
m forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` if Bool
optional then Severity
Warning else Severity
Error

progressCancelHandler :: (m ~ LspM config) => LogAction m (WithSeverity LspProcessingLog) -> TMessage Method_WindowWorkDoneProgressCancel -> m ()
progressCancelHandler :: forall (m :: * -> *) config.
((m :: (* -> *)) ~ (LspM config :: (* -> *))) =>
LogAction m (WithSeverity LspProcessingLog)
-> TMessage
     @'ClientToServer
     @'Notification
     'Method_WindowWorkDoneProgressCancel
-> m ()
progressCancelHandler LogAction m (WithSeverity LspProcessingLog)
logger (TNotificationMessage Text
_ SMethod
  @'ClientToServer
  @'Notification
  'Method_WindowWorkDoneProgressCancel
_ (WorkDoneProgressCancelParams ProgressToken
tid)) = do
  Map ProgressToken (IO ())
pdata <- forall config (m :: * -> *) a.
MonadLsp config m =>
(LanguageContextState config -> TVar a) -> m a
getsState (ProgressData -> TVar (Map ProgressToken (IO ()))
progressCancel forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall config. LanguageContextState config -> ProgressData
resProgressData)
  case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ProgressToken
tid Map ProgressToken (IO ())
pdata of
    Maybe (IO ())
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just IO ()
cancelAction -> do
      LogAction m (WithSeverity LspProcessingLog)
logger forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& ProgressToken -> LspProcessingLog
ProgressCancel ProgressToken
tid forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` Severity
Debug
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
cancelAction

exitNotificationHandler :: (MonadIO m) => LogAction m (WithSeverity LspProcessingLog) -> Handler m Method_Exit
exitNotificationHandler :: forall (m :: * -> *).
MonadIO m =>
LogAction m (WithSeverity LspProcessingLog)
-> Handler @'ClientToServer @'Notification m 'Method_Exit
exitNotificationHandler LogAction m (WithSeverity LspProcessingLog)
logger TNotificationMessage @'ClientToServer 'Method_Exit
_ = do
  LogAction m (WithSeverity LspProcessingLog)
logger forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& LspProcessingLog
Exiting forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` Severity
Info
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a. IO a
exitSuccess

-- | Default Shutdown handler
shutdownRequestHandler :: Handler IO Method_Shutdown
shutdownRequestHandler :: Handler @'ClientToServer @'Request IO 'Method_Shutdown
shutdownRequestHandler TRequestMessage @'ClientToServer 'Method_Shutdown
_req Either ResponseError Null -> IO ()
k = do
  Either ResponseError Null -> IO ()
k forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right Null
Null

-- | Try to find the configuration section in an object that might represent "all" the settings.
-- The heuristic we use is to look for a property with the right name, and use that if we find
-- it. Otherwise we fall back to the whole object.
-- See Note [LSP configuration]
lookForConfigSection :: T.Text -> Value -> Value
lookForConfigSection :: Text -> Value -> Value
lookForConfigSection Text
section (Object Object
o) | Just Value
s' <- Object
o forall s a. s -> Getting a s a -> a
^. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at (forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
section) = Value
s'
lookForConfigSection Text
_ Value
o = Value
o

-- | Handle a workspace/didChangeConfiguration request.
handleDidChangeConfiguration :: (m ~ LspM config) => LogAction m (WithSeverity LspProcessingLog) -> TMessage Method_WorkspaceDidChangeConfiguration -> m ()
handleDidChangeConfiguration :: forall (m :: * -> *) config.
((m :: (* -> *)) ~ (LspM config :: (* -> *))) =>
LogAction m (WithSeverity LspProcessingLog)
-> TMessage
     @'ClientToServer
     @'Notification
     'Method_WorkspaceDidChangeConfiguration
-> m ()
handleDidChangeConfiguration LogAction m (WithSeverity LspProcessingLog)
logger TMessage
  @'ClientToServer
  @'Notification
  'Method_WorkspaceDidChangeConfiguration
req = do
  Text
section <- forall config (m :: * -> *) a.
ReaderT (LanguageContextEnv config) m a -> LspT config m a
LspT forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall config. LanguageContextEnv config -> Text
resConfigSection
  -- See Note [LSP configuration]

  -- There are a few cases:
  -- 1. Client supports `workspace/configuration` and sends nothing in `workspace/didChangeConfiguration`
  --    Then we will fail the first attempt and succeed the second one.
  -- 2. Client does not support `workspace/configuration` and sends updated config in `workspace/didChangeConfiguration`.
  --    Then we will succeed the first attempt and fail (or in fact do nothing in) the second one.
  -- 3. Client supports `workspace/configuration` and sends updated config in `workspace/didChangeConfiguration`.
  --    Then both will succeed, which is a bit redundant but not a big deal.
  forall (m :: * -> *) config.
((m :: (* -> *)) ~ (LspM config :: (* -> *))) =>
LogAction m (WithSeverity LspCoreLog) -> Value -> m ()
tryChangeConfig (forall a b (m :: * -> *).
(a -> b) -> LogAction m b -> LogAction m a
cmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LspCoreLog -> LspProcessingLog
LspCore) LogAction m (WithSeverity LspProcessingLog)
logger) (Text -> Value -> Value
lookForConfigSection Text
section forall a b. (a -> b) -> a -> b
$ TMessage
  @'ClientToServer
  @'Notification
  'Method_WorkspaceDidChangeConfiguration
req forall s a. s -> Getting a s a -> a
^. forall s a. HasParams s a => Lens' s a
L.params forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasSettings s a => Lens' s a
L.settings)
  forall (m :: * -> *) config.
((m :: (* -> *)) ~ (LspM config :: (* -> *))) =>
LogAction m (WithSeverity LspCoreLog) -> m ()
requestConfigUpdate (forall a b (m :: * -> *).
(a -> b) -> LogAction m b -> LogAction m a
cmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LspCoreLog -> LspProcessingLog
LspCore) LogAction m (WithSeverity LspProcessingLog)
logger)

vfsFunc :: forall m n a config
        . (m ~ LspM config, n ~ WriterT [WithSeverity VfsLog] (State VFS))
        => LogAction m (WithSeverity LspProcessingLog)
        -> (LogAction n (WithSeverity VfsLog) -> a -> n ())
        -> a
        -> m ()
vfsFunc :: forall (m :: * -> *) (n :: * -> *) a config.
((m :: (* -> *)) ~ (LspM config :: (* -> *)),
 (n :: (* -> *))
 ~ (WriterT [WithSeverity VfsLog] (State VFS) :: (* -> *))) =>
LogAction m (WithSeverity LspProcessingLog)
-> (LogAction n (WithSeverity VfsLog) -> a -> n ()) -> a -> m ()
vfsFunc LogAction m (WithSeverity LspProcessingLog)
logger LogAction n (WithSeverity VfsLog) -> a -> n ()
modifyVfs a
req = do
  -- This is an intricate dance. We want to run the VFS functions essentially in STM, that's
  -- what 'stateState' does. But we also want them to log. We accomplish this by exfiltrating
  -- the logs through the return value of 'stateState' and then re-logging them.
  -- We therefore have to use the stupid approach of accumulating the logs in Writer inside
  -- the VFS functions. They don't log much so for now we just use [Log], but we could use
  -- DList here if we're worried about performance.
  [WithSeverity VfsLog]
logs <- forall config (m :: * -> *) s a.
MonadLsp config m =>
(LanguageContextState config -> TVar s) -> (s -> (a, s)) -> m a
stateState forall config. LanguageContextState config -> TVar VFSData
resVFS forall a b. (a -> b) -> a -> b
$ \(VFSData VFS
vfs Map String String
rm) ->
    let ([WithSeverity VfsLog]
ls, VFS
vfs') = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s a. State s a -> s -> (a, s)
runState VFS
vfs forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) w a. Monad m => WriterT w m a -> m w
execWriterT forall a b. (a -> b) -> a -> b
$ LogAction n (WithSeverity VfsLog) -> a -> n ()
modifyVfs LogAction n (WithSeverity VfsLog)
innerLogger a
req
    in ([WithSeverity VfsLog]
ls, VFS -> Map String String -> VFSData
VFSData VFS
vfs' Map String String
rm)
  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\WithSeverity VfsLog
l -> LogAction m (WithSeverity LspProcessingLog)
logger forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap VfsLog -> LspProcessingLog
VfsLog WithSeverity VfsLog
l) [WithSeverity VfsLog]
logs
    where
      innerLogger :: LogAction n (WithSeverity VfsLog)
      innerLogger :: LogAction n (WithSeverity VfsLog)
innerLogger = forall (m :: * -> *) msg. (msg -> m ()) -> LogAction m msg
LogAction forall a b. (a -> b) -> a -> b
$ \WithSeverity VfsLog
m -> forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [WithSeverity VfsLog
m]

-- | Updates the list of workspace folders
updateWorkspaceFolders :: TMessage Method_WorkspaceDidChangeWorkspaceFolders -> LspM config ()
updateWorkspaceFolders :: forall config.
TMessage
  @'ClientToServer
  @'Notification
  'Method_WorkspaceDidChangeWorkspaceFolders
-> LspM config ()
updateWorkspaceFolders (TNotificationMessage Text
_ SMethod
  @'ClientToServer
  @'Notification
  'Method_WorkspaceDidChangeWorkspaceFolders
_ MessageParams
  @'ClientToServer
  @'Notification
  'Method_WorkspaceDidChangeWorkspaceFolders
params) = do
  let toRemove :: [WorkspaceFolder]
toRemove = MessageParams
  @'ClientToServer
  @'Notification
  'Method_WorkspaceDidChangeWorkspaceFolders
params forall s a. s -> Getting a s a -> a
^. forall s a. HasEvent s a => Lens' s a
L.event forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasRemoved s a => Lens' s a
L.removed
      toAdd :: [WorkspaceFolder]
toAdd = MessageParams
  @'ClientToServer
  @'Notification
  'Method_WorkspaceDidChangeWorkspaceFolders
params forall s a. s -> Getting a s a -> a
^. forall s a. HasEvent s a => Lens' s a
L.event forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasAdded s a => Lens' s a
L.added
      newWfs :: [WorkspaceFolder] -> [WorkspaceFolder]
newWfs [WorkspaceFolder]
oldWfs = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall a. Eq a => a -> [a] -> [a]
delete [WorkspaceFolder]
oldWfs [WorkspaceFolder]
toRemove forall a. Semigroup a => a -> a -> a
<> [WorkspaceFolder]
toAdd
  forall config (m :: * -> *) a.
MonadLsp config m =>
(LanguageContextState config -> TVar a) -> (a -> a) -> m ()
modifyState forall config.
LanguageContextState config -> TVar [WorkspaceFolder]
resWorkspaceFolders [WorkspaceFolder] -> [WorkspaceFolder]
newWfs

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