{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE RecursiveDo #-}
-- there's just so much!
{-# OPTIONS_GHC -Wno-name-shadowing #-}
{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}

module Language.LSP.Server.Processing where

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

import Control.Concurrent.Extra as C
import Control.Concurrent.STM
import Control.Exception qualified 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 Data.ByteString.Lazy qualified as BSL
import Data.Foldable (traverse_)
import Data.Functor.Product qualified as P
import Data.IxMap
import Data.List
import Data.List.NonEmpty (NonEmpty (..))
import Data.Map.Strict qualified as Map
import Data.Monoid
import Data.String (fromString)
import Data.Text qualified as T
import Data.Text.Lazy.Encoding qualified as TL
import Language.LSP.Protocol.Lens qualified as L
import Language.LSP.Protocol.Message
import Language.LSP.Protocol.Types
import Language.LSP.Protocol.Utils.SMethodMap (SMethodMap)
import Language.LSP.Protocol.Utils.SMethodMap qualified as SMethodMap
import Language.LSP.Server.Core
import Language.LSP.VFS as VFS
import Prettyprinter
import System.Exit

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

deriving instance Show LspProcessingLog

instance Pretty LspProcessingLog where
  pretty :: forall ann. LspProcessingLog -> Doc ann
pretty (VfsLog VfsLog
l) = VfsLog -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. VfsLog -> Doc ann
pretty VfsLog
l
  pretty (LspCore LspCoreLog
l) = LspCoreLog -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. LspCoreLog -> Doc ann
pretty LspCoreLog
l
  pretty (MessageProcessingError ByteString
bs String
err) =
    [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep
      [ Doc ann
"LSP: incoming message parse error:"
      , String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
err
      , Doc ann
"when processing"
      , Text -> Doc ann
forall ann. Text -> Doc ann
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:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> SClientMethod @t m -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. SClientMethod @t m -> Doc ann
pretty SClientMethod @t m
m
  pretty (ProgressCancel ProgressToken
tid) = Doc ann
"LSP: cancelling action for token:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ProgressToken -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. ProgressToken -> Doc ann
pretty ProgressToken
tid
  pretty (MessageDuringShutdown SClientMethod @t m
m) = Doc ann
"LSP: received message during shutdown:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> SClientMethod @t m -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. SClientMethod @t m -> Doc ann
pretty SClientMethod @t m
m
  pretty LspProcessingLog
ShuttingDown = Doc ann
"LSP: received shutdown"
  pretty LspProcessingLog
Exiting = Doc ann
"LSP: received exit"

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 <- ReaderT (LanguageContextEnv config) IO (TVar ResponseMap)
-> LspT config IO (TVar ResponseMap)
forall config (m :: * -> *) a.
ReaderT (LanguageContextEnv config) m a -> LspT config m a
LspT (ReaderT (LanguageContextEnv config) IO (TVar ResponseMap)
 -> LspT config IO (TVar ResponseMap))
-> ReaderT (LanguageContextEnv config) IO (TVar ResponseMap)
-> LspT config IO (TVar ResponseMap)
forall a b. (a -> b) -> a -> b
$ (LanguageContextEnv config -> TVar ResponseMap)
-> ReaderT (LanguageContextEnv config) IO (TVar ResponseMap)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((LanguageContextEnv config -> TVar ResponseMap)
 -> ReaderT (LanguageContextEnv config) IO (TVar ResponseMap))
-> (LanguageContextEnv config -> TVar ResponseMap)
-> ReaderT (LanguageContextEnv config) IO (TVar ResponseMap)
forall a b. (a -> b) -> a -> b
$ LanguageContextState config -> TVar ResponseMap
forall config. LanguageContextState config -> TVar ResponseMap
resPendingResponses (LanguageContextState config -> TVar ResponseMap)
-> (LanguageContextEnv config -> LanguageContextState config)
-> LanguageContextEnv config
-> TVar ResponseMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LanguageContextEnv config -> LanguageContextState config
forall config.
LanguageContextEnv config -> LanguageContextState config
resState
  Bool
shutdown <- m Bool
forall (m :: * -> *) config.
((m :: (* -> *)) ~ (LspM config :: (* -> *))) =>
m Bool
isShuttingDown
  m (m ()) -> m ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (m (m ()) -> m ()) -> m (m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ IO (m ()) -> m (m ())
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (m ()) -> m (m ())) -> IO (m ()) -> m (m ())
forall a b. (a -> b) -> a -> b
$ STM (m ()) -> IO (m ())
forall a. STM a -> IO a
atomically (STM (m ()) -> IO (m ())) -> STM (m ()) -> IO (m ())
forall a b. (a -> b) -> a -> b
$ (Either String (m ()) -> m ())
-> STM (Either String (m ())) -> STM (m ())
forall a b. (a -> b) -> STM a -> STM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either String (m ()) -> m ()
handleErrors (STM (Either String (m ())) -> STM (m ()))
-> STM (Either String (m ())) -> STM (m ())
forall a b. (a -> b) -> a -> b
$ ExceptT String STM (m ()) -> STM (Either String (m ()))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT String STM (m ()) -> STM (Either String (m ())))
-> ExceptT String STM (m ()) -> STM (Either String (m ()))
forall a b. (a -> b) -> a -> b
$ do
    Value
val <- Either String Value -> ExceptT String STM Value
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either String Value -> ExceptT String STM Value)
-> Either String Value -> ExceptT String STM Value
forall a b. (a -> b) -> a -> b
$ ByteString -> Either String Value
forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
jsonStr
    ResponseMap
pending <- STM ResponseMap -> ExceptT String STM ResponseMap
forall (m :: * -> *) a. Monad m => m a -> ExceptT String m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (STM ResponseMap -> ExceptT String STM ResponseMap)
-> STM ResponseMap -> ExceptT String STM ResponseMap
forall a b. (a -> b) -> a -> b
$ TVar ResponseMap -> STM ResponseMap
forall a. TVar a -> STM a
readTVar TVar ResponseMap
pendingResponsesVar
    FromClientMessage'
  (Product
     @(Method 'ServerToClient 'Request)
     ServerResponseCallback
     (Const @(Method 'ServerToClient 'Request) ResponseMap))
msg <- Either
  String
  (FromClientMessage'
     (Product
        @(Method 'ServerToClient 'Request)
        ServerResponseCallback
        (Const @(Method 'ServerToClient 'Request) ResponseMap)))
-> ExceptT
     String
     STM
     (FromClientMessage'
        (Product
           @(Method 'ServerToClient 'Request)
           ServerResponseCallback
           (Const @(Method 'ServerToClient 'Request) ResponseMap)))
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either
   String
   (FromClientMessage'
      (Product
         @(Method 'ServerToClient 'Request)
         ServerResponseCallback
         (Const @(Method 'ServerToClient 'Request) ResponseMap)))
 -> ExceptT
      String
      STM
      (FromClientMessage'
         (Product
            @(Method 'ServerToClient 'Request)
            ServerResponseCallback
            (Const @(Method 'ServerToClient 'Request) ResponseMap))))
-> Either
     String
     (FromClientMessage'
        (Product
           @(Method 'ServerToClient 'Request)
           ServerResponseCallback
           (Const @(Method 'ServerToClient 'Request) ResponseMap)))
-> ExceptT
     String
     STM
     (FromClientMessage'
        (Product
           @(Method 'ServerToClient 'Request)
           ServerResponseCallback
           (Const @(Method 'ServerToClient 'Request) ResponseMap)))
forall a b. (a -> b) -> a -> b
$ (Value
 -> Parser
      (FromClientMessage'
         (Product
            @(Method 'ServerToClient 'Request)
            ServerResponseCallback
            (Const @(Method 'ServerToClient 'Request) ResponseMap))))
-> Value
-> Either
     String
     (FromClientMessage'
        (Product
           @(Method 'ServerToClient 'Request)
           ServerResponseCallback
           (Const @(Method 'ServerToClient 'Request) ResponseMap)))
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
    STM (m ()) -> ExceptT String STM (m ())
forall (m :: * -> *) a. Monad m => m a -> ExceptT String m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (STM (m ()) -> ExceptT String STM (m ()))
-> STM (m ()) -> ExceptT String STM (m ())
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 ->
        m () -> STM (m ())
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (m () -> STM (m ())) -> m () -> STM (m ())
forall a b. (a -> b) -> a -> b
$ LogAction m (WithSeverity LspProcessingLog)
-> SMethod @'ClientToServer @t m
-> TMessage @'ClientToServer @t m
-> m ()
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
  (TResponseError @'ServerToClient m)
  (MessageResult @'ServerToClient @'Request m)
-> IO ()
f) (Const !ResponseMap
newMap)) TResponseMessage @'ServerToClient m
res -> do
        -- see Note [Shutdown]
        TVar ResponseMap -> ResponseMap -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar ResponseMap
pendingResponsesVar ResponseMap
newMap
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
shutdown (m () -> m ()) -> STM (m ()) -> STM (m ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
          m () -> STM (m ())
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (m () -> STM (m ())) -> m () -> STM (m ())
forall a b. (a -> b) -> a -> b
$ IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Either
  (TResponseError @'ServerToClient m)
  (MessageResult @'ServerToClient @'Request m)
-> IO ()
f (TResponseMessage @'ServerToClient m
res TResponseMessage @'ServerToClient m
-> Getting
     (Either
        (TResponseError @'ServerToClient m)
        (MessageResult @'ServerToClient @'Request m))
     (TResponseMessage @'ServerToClient m)
     (Either
        (TResponseError @'ServerToClient m)
        (MessageResult @'ServerToClient @'Request m))
-> Either
     (TResponseError @'ServerToClient m)
     (MessageResult @'ServerToClient @'Request m)
forall s a. s -> Getting a s a -> a
^. Getting
  (Either
     (TResponseError @'ServerToClient m)
     (MessageResult @'ServerToClient @'Request m))
  (TResponseMessage @'ServerToClient m)
  (Either
     (TResponseError @'ServerToClient m)
     (MessageResult @'ServerToClient @'Request m))
forall s a. HasResult s a => Lens' s a
Lens'
  (TResponseMessage @'ServerToClient m)
  (Either
     (TResponseError @'ServerToClient m)
     (MessageResult @'ServerToClient @'Request m))
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 = LookupFunc
  'ServerToClient
  (Product
     @(Method 'ServerToClient 'Request)
     ServerResponseCallback
     (Const @(Method 'ServerToClient 'Request) ResponseMap))
-> Value
-> Parser
     (FromClientMessage'
        (Product
           @(Method 'ServerToClient 'Request)
           ServerResponseCallback
           (Const @(Method 'ServerToClient 'Request) ResponseMap)))
forall (a :: Method 'ServerToClient 'Request -> *).
LookupFunc 'ServerToClient a
-> Value -> Parser (FromClientMessage' a)
parseClientMessage (LookupFunc
   'ServerToClient
   (Product
      @(Method 'ServerToClient 'Request)
      ServerResponseCallback
      (Const @(Method 'ServerToClient 'Request) ResponseMap))
 -> Value
 -> Parser
      (FromClientMessage'
         (Product
            @(Method 'ServerToClient 'Request)
            ServerResponseCallback
            (Const @(Method 'ServerToClient 'Request) ResponseMap))))
-> LookupFunc
     'ServerToClient
     (Product
        @(Method 'ServerToClient 'Request)
        ServerResponseCallback
        (Const @(Method 'ServerToClient 'Request) ResponseMap))
-> Value
-> Parser
     (FromClientMessage'
        (Product
           @(Method 'ServerToClient 'Request)
           ServerResponseCallback
           (Const @(Method 'ServerToClient 'Request) ResponseMap)))
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) = LspId @'ServerToClient m
-> ResponseMap
-> (Maybe
      (Product
         @(Method 'ServerToClient 'Request)
         (SMethod @'ServerToClient @'Request)
         ServerResponseCallback
         m),
    ResponseMap)
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, ServerResponseCallback m
-> Const @(Method 'ServerToClient 'Request) ResponseMap m
-> Product
     @(Method 'ServerToClient 'Request)
     ServerResponseCallback
     (Const @(Method 'ServerToClient 'Request) ResponseMap)
     m
forall {k} (f :: k -> *) (g :: k -> *) (a :: k).
f a -> g a -> Product @k f g a
P.Pair ServerResponseCallback m
handler (ResponseMap
-> Const @(Method 'ServerToClient 'Request) ResponseMap m
forall {k} a (b :: k). a -> Const @k a b
Const ResponseMap
newMap))) (Product
   @(Method 'ServerToClient 'Request)
   (SMethod @'ServerToClient @'Request)
   ServerResponseCallback
   m
 -> (SMethod @'ServerToClient @'Request m,
     Product
       @(Method 'ServerToClient 'Request)
       ServerResponseCallback
       (Const @(Method 'ServerToClient 'Request) ResponseMap)
       m))
-> Maybe
     (Product
        @(Method 'ServerToClient 'Request)
        (SMethod @'ServerToClient @'Request)
        ServerResponseCallback
        m)
-> Maybe
     (SMethod @'ServerToClient @'Request m,
      Product
        @(Method 'ServerToClient 'Request)
        ServerResponseCallback
        (Const @(Method 'ServerToClient 'Request) ResponseMap)
        m)
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 = (String -> m ()) -> (m () -> m ()) -> Either String (m ()) -> m ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\String
e -> LogAction m (WithSeverity LspProcessingLog)
logger LogAction m (WithSeverity LspProcessingLog)
-> WithSeverity LspProcessingLog -> m ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& ByteString -> String -> LspProcessingLog
MessageProcessingError ByteString
jsonStr String
e LspProcessingLog -> Severity -> WithSeverity LspProcessingLog
forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` Severity
Error) m () -> m ()
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 (TResponseError @'ClientToServer 'Method_Initialize) a)
defaultConfig :: config
configSection :: Text
parseConfig :: config -> Value -> Either Text config
onConfigChange :: config -> m ()
doInitialize :: LanguageContextEnv config
-> TMessage @'ClientToServer @'Request 'Method_Initialize
-> IO
     (Either (TResponseError @'ClientToServer 'Method_Initialize) a)
staticHandlers :: ClientCapabilities -> Handlers m
interpretHandler :: a -> (<~>) @(*) m IO
options :: Options
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
..} VFS
vfs FromServerMessage -> IO ()
sendFunc TMessage @'ClientToServer @'Request 'Method_Initialize
req = do
  let sendResp :: TResponseMessage @'ClientToServer 'Method_Initialize -> IO ()
sendResp = FromServerMessage -> IO ()
sendFunc (FromServerMessage -> IO ())
-> (TResponseMessage @'ClientToServer 'Method_Initialize
    -> FromServerMessage)
-> TResponseMessage @'ClientToServer 'Method_Initialize
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SMethod @'ClientToServer @'Request 'Method_Initialize
-> TResponseMessage @'ClientToServer 'Method_Initialize
-> FromServerMessage
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
  (TResponseError @'ClientToServer 'Method_Initialize)
  (LanguageContextEnv config)
-> IO (Maybe (LanguageContextEnv config))
handleErr (Left TResponseError @'ClientToServer 'Method_Initialize
err) = do
        TResponseMessage @'ClientToServer 'Method_Initialize -> IO ()
sendResp (TResponseMessage @'ClientToServer 'Method_Initialize -> IO ())
-> TResponseMessage @'ClientToServer 'Method_Initialize -> IO ()
forall a b. (a -> b) -> a -> b
$ LspId @'ClientToServer 'Method_Initialize
-> TResponseError @'ClientToServer 'Method_Initialize
-> TResponseMessage @'ClientToServer 'Method_Initialize
forall {f :: MessageDirection} {m :: Method f 'Request}.
LspId @f m -> TResponseError @f m -> TResponseMessage @f m
makeResponseError (TMessage @'ClientToServer @'Request 'Method_Initialize
TRequestMessage @'ClientToServer 'Method_Initialize
req TRequestMessage @'ClientToServer 'Method_Initialize
-> Getting
     (LspId @'ClientToServer 'Method_Initialize)
     (TRequestMessage @'ClientToServer 'Method_Initialize)
     (LspId @'ClientToServer 'Method_Initialize)
-> LspId @'ClientToServer 'Method_Initialize
forall s a. s -> Getting a s a -> a
^. Getting
  (LspId @'ClientToServer 'Method_Initialize)
  (TRequestMessage @'ClientToServer 'Method_Initialize)
  (LspId @'ClientToServer 'Method_Initialize)
forall s a. HasId s a => Lens' s a
Lens'
  (TRequestMessage @'ClientToServer 'Method_Initialize)
  (LspId @'ClientToServer 'Method_Initialize)
L.id) TResponseError @'ClientToServer 'Method_Initialize
err
        Maybe (LanguageContextEnv config)
-> IO (Maybe (LanguageContextEnv config))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (LanguageContextEnv config)
forall a. Maybe a
Nothing
      handleErr (Right LanguageContextEnv config
a) = Maybe (LanguageContextEnv config)
-> IO (Maybe (LanguageContextEnv config))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (LanguageContextEnv config)
 -> IO (Maybe (LanguageContextEnv config)))
-> Maybe (LanguageContextEnv config)
-> IO (Maybe (LanguageContextEnv config))
forall a b. (a -> b) -> a -> b
$ LanguageContextEnv config -> Maybe (LanguageContextEnv config)
forall a. a -> Maybe a
Just LanguageContextEnv config
a
  (SomeException -> IO (Maybe (LanguageContextEnv config)))
-> IO (Maybe (LanguageContextEnv config))
-> IO (Maybe (LanguageContextEnv config))
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
E.handle ((TResponseError @'ClientToServer 'Method_Initialize -> IO ())
-> SomeException -> IO (Maybe (LanguageContextEnv config))
forall a.
(TResponseError @'ClientToServer 'Method_Initialize -> IO ())
-> SomeException -> IO (Maybe a)
initializeErrorHandler ((TResponseError @'ClientToServer 'Method_Initialize -> IO ())
 -> SomeException -> IO (Maybe (LanguageContextEnv config)))
-> (TResponseError @'ClientToServer 'Method_Initialize -> IO ())
-> SomeException
-> IO (Maybe (LanguageContextEnv config))
forall a b. (a -> b) -> a -> b
$ TResponseMessage @'ClientToServer 'Method_Initialize -> IO ()
sendResp (TResponseMessage @'ClientToServer 'Method_Initialize -> IO ())
-> (TResponseError @'ClientToServer 'Method_Initialize
    -> TResponseMessage @'ClientToServer 'Method_Initialize)
-> TResponseError @'ClientToServer 'Method_Initialize
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LspId @'ClientToServer 'Method_Initialize
-> TResponseError @'ClientToServer 'Method_Initialize
-> TResponseMessage @'ClientToServer 'Method_Initialize
forall {f :: MessageDirection} {m :: Method f 'Request}.
LspId @f m -> TResponseError @f m -> TResponseMessage @f m
makeResponseError (TMessage @'ClientToServer @'Request 'Method_Initialize
TRequestMessage @'ClientToServer 'Method_Initialize
req TRequestMessage @'ClientToServer 'Method_Initialize
-> Getting
     (LspId @'ClientToServer 'Method_Initialize)
     (TRequestMessage @'ClientToServer 'Method_Initialize)
     (LspId @'ClientToServer 'Method_Initialize)
-> LspId @'ClientToServer 'Method_Initialize
forall s a. s -> Getting a s a -> a
^. Getting
  (LspId @'ClientToServer 'Method_Initialize)
  (TRequestMessage @'ClientToServer 'Method_Initialize)
  (LspId @'ClientToServer 'Method_Initialize)
forall s a. HasId s a => Lens' s a
Lens'
  (TRequestMessage @'ClientToServer 'Method_Initialize)
  (LspId @'ClientToServer 'Method_Initialize)
L.id)) (IO (Maybe (LanguageContextEnv config))
 -> IO (Maybe (LanguageContextEnv config)))
-> IO (Maybe (LanguageContextEnv config))
-> IO (Maybe (LanguageContextEnv config))
forall a b. (a -> b) -> a -> b
$ Either
  (TResponseError @'ClientToServer 'Method_Initialize)
  (LanguageContextEnv config)
-> IO (Maybe (LanguageContextEnv config))
handleErr (Either
   (TResponseError @'ClientToServer 'Method_Initialize)
   (LanguageContextEnv config)
 -> IO (Maybe (LanguageContextEnv config)))
-> (ExceptT
      (TResponseError @'ClientToServer 'Method_Initialize)
      IO
      (LanguageContextEnv config)
    -> IO
         (Either
            (TResponseError @'ClientToServer 'Method_Initialize)
            (LanguageContextEnv config)))
-> ExceptT
     (TResponseError @'ClientToServer 'Method_Initialize)
     IO
     (LanguageContextEnv config)
-> IO (Maybe (LanguageContextEnv config))
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< ExceptT
  (TResponseError @'ClientToServer 'Method_Initialize)
  IO
  (LanguageContextEnv config)
-> IO
     (Either
        (TResponseError @'ClientToServer 'Method_Initialize)
        (LanguageContextEnv config))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT
   (TResponseError @'ClientToServer 'Method_Initialize)
   IO
   (LanguageContextEnv config)
 -> IO (Maybe (LanguageContextEnv config)))
-> ExceptT
     (TResponseError @'ClientToServer 'Method_Initialize)
     IO
     (LanguageContextEnv config)
-> IO (Maybe (LanguageContextEnv config))
forall a b. (a -> b) -> a -> b
$ mdo
    let p :: InitializeParams
p = TMessage @'ClientToServer @'Request 'Method_Initialize
TRequestMessage @'ClientToServer 'Method_Initialize
req TRequestMessage @'ClientToServer 'Method_Initialize
-> Getting
     InitializeParams
     (TRequestMessage @'ClientToServer 'Method_Initialize)
     InitializeParams
-> InitializeParams
forall s a. s -> Getting a s a -> a
^. Getting
  InitializeParams
  (TRequestMessage @'ClientToServer 'Method_Initialize)
  InitializeParams
forall s a. HasParams s a => Lens' s a
Lens'
  (TRequestMessage @'ClientToServer 'Method_Initialize)
  InitializeParams
L.params
        rootDir :: Maybe String
rootDir =
          First String -> Maybe String
forall a. First a -> Maybe a
getFirst (First String -> Maybe String) -> First String -> Maybe String
forall a b. (a -> b) -> a -> b
$
            (Maybe String -> First String) -> [Maybe String] -> First String
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
              Maybe String -> First String
forall a. Maybe a -> First a
First
              [ InitializeParams
p InitializeParams
-> Getting (First Uri) InitializeParams Uri -> Maybe Uri
forall s a. s -> Getting (First a) s a -> Maybe a
^? ((Uri |? Null) -> Const @(*) (First Uri) (Uri |? Null))
-> InitializeParams -> Const @(*) (First Uri) InitializeParams
forall s a. HasRootUri s a => Lens' s a
Lens' InitializeParams (Uri |? Null)
L.rootUri (((Uri |? Null) -> Const @(*) (First Uri) (Uri |? Null))
 -> InitializeParams -> Const @(*) (First Uri) InitializeParams)
-> ((Uri -> Const @(*) (First Uri) Uri)
    -> (Uri |? Null) -> Const @(*) (First Uri) (Uri |? Null))
-> Getting (First Uri) InitializeParams Uri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Uri -> Const @(*) (First Uri) Uri)
-> (Uri |? Null) -> Const @(*) (First Uri) (Uri |? Null)
forall a b (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p a (f a) -> p (a |? b) (f (a |? b))
_L Maybe Uri -> (Uri -> Maybe String) -> Maybe String
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Uri -> Maybe String
uriToFilePath
              , InitializeParams
p InitializeParams
-> Getting (First Text) InitializeParams Text -> Maybe Text
forall s a. s -> Getting (First a) s a -> Maybe a
^? (Maybe (Text |? Null)
 -> Const @(*) (First Text) (Maybe (Text |? Null)))
-> InitializeParams -> Const @(*) (First Text) InitializeParams
forall s a. HasRootPath s a => Lens' s a
Lens' InitializeParams (Maybe (Text |? Null))
L.rootPath ((Maybe (Text |? Null)
  -> Const @(*) (First Text) (Maybe (Text |? Null)))
 -> InitializeParams -> Const @(*) (First Text) InitializeParams)
-> ((Text -> Const @(*) (First Text) Text)
    -> Maybe (Text |? Null)
    -> Const @(*) (First Text) (Maybe (Text |? Null)))
-> Getting (First Text) InitializeParams Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text |? Null) -> Const @(*) (First Text) (Text |? Null))
-> Maybe (Text |? Null)
-> Const @(*) (First Text) (Maybe (Text |? Null))
forall a b (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p a (f b) -> p (Maybe a) (f (Maybe b))
_Just (((Text |? Null) -> Const @(*) (First Text) (Text |? Null))
 -> Maybe (Text |? Null)
 -> Const @(*) (First Text) (Maybe (Text |? Null)))
-> ((Text -> Const @(*) (First Text) Text)
    -> (Text |? Null) -> Const @(*) (First Text) (Text |? Null))
-> (Text -> Const @(*) (First Text) Text)
-> Maybe (Text |? Null)
-> Const @(*) (First Text) (Maybe (Text |? Null))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Const @(*) (First Text) Text)
-> (Text |? Null) -> Const @(*) (First Text) (Text |? Null)
forall a b (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p a (f a) -> p (a |? b) (f (a |? b))
_L Maybe Text -> (Text -> String) -> Maybe String
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Text -> String
T.unpack
              ]
        clientCaps :: ClientCapabilities
clientCaps = InitializeParams
p InitializeParams
-> Getting ClientCapabilities InitializeParams ClientCapabilities
-> ClientCapabilities
forall s a. s -> Getting a s a -> a
^. Getting ClientCapabilities InitializeParams ClientCapabilities
forall s a. HasCapabilities s a => Lens' s a
Lens' InitializeParams ClientCapabilities
L.capabilities

    let initialWfs :: [WorkspaceFolder]
initialWfs = case InitializeParams
p InitializeParams
-> Getting
     (Maybe ([WorkspaceFolder] |? Null))
     InitializeParams
     (Maybe ([WorkspaceFolder] |? Null))
-> Maybe ([WorkspaceFolder] |? Null)
forall s a. s -> Getting a s a -> a
^. Getting
  (Maybe ([WorkspaceFolder] |? Null))
  InitializeParams
  (Maybe ([WorkspaceFolder] |? Null))
forall s a. HasWorkspaceFolders s a => Lens' s a
Lens' InitializeParams (Maybe ([WorkspaceFolder] |? Null))
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 (Value -> Value) -> Maybe Value -> Maybe Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (InitializeParams
p InitializeParams
-> Getting (Maybe Value) InitializeParams (Maybe Value)
-> Maybe Value
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Value) InitializeParams (Maybe Value)
forall s a. HasInitializationOptions s a => Lens' s a
Lens' InitializeParams (Maybe Value)
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 -> do
          IO ()
-> ExceptT
     (TResponseError @'ClientToServer 'Method_Initialize) IO ()
forall a.
IO a
-> ExceptT
     (TResponseError @'ClientToServer 'Method_Initialize) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ()
 -> ExceptT
      (TResponseError @'ClientToServer 'Method_Initialize) IO ())
-> IO ()
-> ExceptT
     (TResponseError @'ClientToServer 'Method_Initialize) IO ()
forall a b. (a -> b) -> a -> b
$ LogAction IO (WithSeverity LspProcessingLog)
logger LogAction IO (WithSeverity LspProcessingLog)
-> WithSeverity LspProcessingLog -> IO ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& LspCoreLog -> LspProcessingLog
LspCore (Value -> LspCoreLog
NewConfig Value
o) LspProcessingLog -> Severity -> WithSeverity LspProcessingLog
forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` Severity
Debug
          config
-> ExceptT
     (TResponseError @'ClientToServer 'Method_Initialize) IO config
forall a.
a
-> ExceptT
     (TResponseError @'ClientToServer 'Method_Initialize) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure config
newConfig
        Left Text
err -> do
          -- Warn not error here, since initializationOptions is pretty unspecified
          IO ()
-> ExceptT
     (TResponseError @'ClientToServer 'Method_Initialize) IO ()
forall a.
IO a
-> ExceptT
     (TResponseError @'ClientToServer 'Method_Initialize) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ()
 -> ExceptT
      (TResponseError @'ClientToServer 'Method_Initialize) IO ())
-> IO ()
-> ExceptT
     (TResponseError @'ClientToServer 'Method_Initialize) IO ()
forall a b. (a -> b) -> a -> b
$ LogAction IO (WithSeverity LspProcessingLog)
logger LogAction IO (WithSeverity LspProcessingLog)
-> WithSeverity LspProcessingLog -> IO ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& LspCoreLog -> LspProcessingLog
LspCore (Value -> Text -> LspCoreLog
ConfigurationParseError Value
o Text
err) LspProcessingLog -> Severity -> WithSeverity LspProcessingLog
forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` Severity
Warning
          config
-> ExceptT
     (TResponseError @'ClientToServer 'Method_Initialize) IO config
forall a.
a
-> ExceptT
     (TResponseError @'ClientToServer 'Method_Initialize) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure config
defaultConfig
      Maybe Value
Nothing -> config
-> ExceptT
     (TResponseError @'ClientToServer 'Method_Initialize) IO config
forall a.
a
-> ExceptT
     (TResponseError @'ClientToServer 'Method_Initialize) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure config
defaultConfig

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

    -- Call the 'duringInitialization' callback to let the server kick stuff up
    let env :: LanguageContextEnv config
env =
          Handlers IO
-> Text
-> (config -> Value -> Either Text config)
-> (config -> IO ())
-> (FromServerMessage -> IO ())
-> LanguageContextState config
-> ClientCapabilities
-> Maybe String
-> Int
-> Int
-> LanguageContextEnv config
forall config.
Handlers IO
-> Text
-> (config -> Value -> Either Text config)
-> (config -> IO ())
-> (FromServerMessage -> IO ())
-> LanguageContextState config
-> ClientCapabilities
-> Maybe String
-> Int
-> Int
-> 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 InitializeParams
-> Getting ClientCapabilities InitializeParams ClientCapabilities
-> ClientCapabilities
forall s a. s -> Getting a s a -> a
^. Getting ClientCapabilities InitializeParams ClientCapabilities
forall s a. HasCapabilities s a => Lens' s a
Lens' InitializeParams ClientCapabilities
L.capabilities)
            Maybe String
rootDir
            (Options -> Int
optProgressStartDelay Options
options)
            (Options -> Int
optProgressUpdateDelay Options
options)
        configChanger :: config -> IO ()
configChanger config
config = (<~>) @(*) m IO -> forall a. m a -> IO a
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 = (<~>) @(*) m IO -> Handlers m -> Handlers IO
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 <- IO (Either (TResponseError @'ClientToServer 'Method_Initialize) a)
-> ExceptT
     (TResponseError @'ClientToServer 'Method_Initialize) IO a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either (TResponseError @'ClientToServer 'Method_Initialize) a)
 -> ExceptT
      (TResponseError @'ClientToServer 'Method_Initialize) IO a)
-> IO
     (Either (TResponseError @'ClientToServer 'Method_Initialize) a)
-> ExceptT
     (TResponseError @'ClientToServer 'Method_Initialize) IO a
forall a b. (a -> b) -> a -> b
$ LanguageContextEnv config
-> TMessage @'ClientToServer @'Request 'Method_Initialize
-> IO
     (Either (TResponseError @'ClientToServer 'Method_Initialize) a)
doInitialize LanguageContextEnv config
env TMessage @'ClientToServer @'Request 'Method_Initialize
req

    let serverCaps :: ServerCapabilities
serverCaps = ClientCapabilities -> Options -> Handlers IO -> ServerCapabilities
forall (m :: * -> *).
ClientCapabilities -> Options -> Handlers m -> ServerCapabilities
inferServerCapabilities ClientCapabilities
clientCaps Options
options Handlers IO
handlers
    IO ()
-> ExceptT
     (TResponseError @'ClientToServer 'Method_Initialize) IO ()
forall a.
IO a
-> ExceptT
     (TResponseError @'ClientToServer 'Method_Initialize) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ()
 -> ExceptT
      (TResponseError @'ClientToServer 'Method_Initialize) IO ())
-> IO ()
-> ExceptT
     (TResponseError @'ClientToServer 'Method_Initialize) IO ()
forall a b. (a -> b) -> a -> b
$ TResponseMessage @'ClientToServer 'Method_Initialize -> IO ()
sendResp (TResponseMessage @'ClientToServer 'Method_Initialize -> IO ())
-> TResponseMessage @'ClientToServer 'Method_Initialize -> IO ()
forall a b. (a -> b) -> a -> b
$ LspId @'ClientToServer 'Method_Initialize
-> MessageResult @'ClientToServer @'Request 'Method_Initialize
-> TResponseMessage @'ClientToServer 'Method_Initialize
forall {f :: MessageDirection} {m :: Method f 'Request}.
LspId @f m -> MessageResult @f @'Request m -> TResponseMessage @f m
makeResponseMessage (TMessage @'ClientToServer @'Request 'Method_Initialize
TRequestMessage @'ClientToServer 'Method_Initialize
req TRequestMessage @'ClientToServer 'Method_Initialize
-> Getting
     (LspId @'ClientToServer 'Method_Initialize)
     (TRequestMessage @'ClientToServer 'Method_Initialize)
     (LspId @'ClientToServer 'Method_Initialize)
-> LspId @'ClientToServer 'Method_Initialize
forall s a. s -> Getting a s a -> a
^. Getting
  (LspId @'ClientToServer 'Method_Initialize)
  (TRequestMessage @'ClientToServer 'Method_Initialize)
  (LspId @'ClientToServer 'Method_Initialize)
forall s a. HasId s a => Lens' s a
Lens'
  (TRequestMessage @'ClientToServer 'Method_Initialize)
  (LspId @'ClientToServer 'Method_Initialize)
L.id) (ServerCapabilities -> Maybe ServerInfo -> InitializeResult
InitializeResult ServerCapabilities
serverCaps (Options -> Maybe ServerInfo
optServerInfo Options
options))
    LanguageContextEnv config
-> ExceptT
     (TResponseError @'ClientToServer 'Method_Initialize)
     IO
     (LanguageContextEnv config)
forall a.
a
-> ExceptT
     (TResponseError @'ClientToServer 'Method_Initialize) IO a
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 = Text
-> Maybe (LspId @f m)
-> Either (TResponseError @f m) (MessageResult @f @'Request m)
-> TResponseMessage @f m
forall (f :: MessageDirection) (m :: Method f 'Request).
Text
-> Maybe (LspId @f m)
-> Either (TResponseError @f m) (MessageResult @f @'Request m)
-> TResponseMessage @f m
TResponseMessage Text
"2.0" (LspId @f m -> Maybe (LspId @f m)
forall a. a -> Maybe a
Just LspId @f m
rid) (MessageResult @f @'Request m
-> Either (TResponseError @f m) (MessageResult @f @'Request m)
forall a b. b -> Either a b
Right MessageResult @f @'Request m
result)
  makeResponseError :: LspId @f m -> TResponseError @f m -> TResponseMessage @f m
makeResponseError LspId @f m
origId TResponseError @f m
err = Text
-> Maybe (LspId @f m)
-> Either (TResponseError @f m) (MessageResult @f @'Request m)
-> TResponseMessage @f m
forall (f :: MessageDirection) (m :: Method f 'Request).
Text
-> Maybe (LspId @f m)
-> Either (TResponseError @f m) (MessageResult @f @'Request m)
-> TResponseMessage @f m
TResponseMessage Text
"2.0" (LspId @f m -> Maybe (LspId @f m)
forall a. a -> Maybe a
Just LspId @f m
origId) (TResponseError @f m
-> Either (TResponseError @f m) (MessageResult @f @'Request m)
forall a b. a -> Either a b
Left TResponseError @f m
err)

  initializeErrorHandler :: (TResponseError Method_Initialize -> IO ()) -> E.SomeException -> IO (Maybe a)
  initializeErrorHandler :: forall a.
(TResponseError @'ClientToServer 'Method_Initialize -> IO ())
-> SomeException -> IO (Maybe a)
initializeErrorHandler TResponseError @'ClientToServer 'Method_Initialize -> IO ()
sendResp SomeException
e = do
    TResponseError @'ClientToServer 'Method_Initialize -> IO ()
sendResp (TResponseError @'ClientToServer 'Method_Initialize -> IO ())
-> TResponseError @'ClientToServer 'Method_Initialize -> IO ()
forall a b. (a -> b) -> a -> b
$ (LSPErrorCodes |? ErrorCodes)
-> Text
-> Maybe (ErrorData @'ClientToServer @'Request 'Method_Initialize)
-> TResponseError @'ClientToServer 'Method_Initialize
forall (f :: MessageDirection) (m :: Method f 'Request).
(LSPErrorCodes |? ErrorCodes)
-> Text -> Maybe (ErrorData @f @'Request m) -> TResponseError @f m
TResponseError (ErrorCodes -> LSPErrorCodes |? ErrorCodes
forall a b. b -> a |? b
InR ErrorCodes
ErrorCodes_InternalError) Text
msg Maybe InitializeError
Maybe (ErrorData @'ClientToServer @'Request 'Method_Initialize)
forall a. Maybe a
Nothing
    Maybe a -> IO (Maybe a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
   where
    msg :: Text
msg = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String
"Error on initialize:", SomeException -> String
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
    { _textDocumentSync :: Maybe (TextDocumentSyncOptions |? TextDocumentSyncKind)
_textDocumentSync = Maybe (TextDocumentSyncOptions |? TextDocumentSyncKind)
sync
    , _hoverProvider :: Maybe (Bool |? HoverOptions)
_hoverProvider =
        SClientMethod @'Request 'Method_TextDocumentHover
-> (Bool |? HoverOptions) -> Maybe (Bool |? HoverOptions)
forall {t :: MessageKind} {m :: Method 'ClientToServer t} {a}.
SClientMethod @t m -> a -> Maybe a
supported' SClientMethod @'Request 'Method_TextDocumentHover
SMethod_TextDocumentHover ((Bool |? HoverOptions) -> Maybe (Bool |? HoverOptions))
-> (Bool |? HoverOptions) -> Maybe (Bool |? HoverOptions)
forall a b. (a -> b) -> a -> b
$
          HoverOptions -> Bool |? HoverOptions
forall a b. b -> a |? b
InR (HoverOptions -> Bool |? HoverOptions)
-> HoverOptions -> Bool |? HoverOptions
forall a b. (a -> b) -> a -> b
$
            Maybe Bool -> HoverOptions
HoverOptions Maybe Bool
clientInitiatedProgress
    , _completionProvider :: Maybe CompletionOptions
_completionProvider = Maybe CompletionOptions
completionProvider
    , _inlayHintProvider :: Maybe (Bool |? (InlayHintOptions |? InlayHintRegistrationOptions))
_inlayHintProvider = Maybe (Bool |? (InlayHintOptions |? InlayHintRegistrationOptions))
inlayProvider
    , _declarationProvider :: Maybe
  (Bool |? (DeclarationOptions |? DeclarationRegistrationOptions))
_declarationProvider =
        SClientMethod @'Request 'Method_TextDocumentDeclaration
-> (Bool |? (DeclarationOptions |? DeclarationRegistrationOptions))
-> Maybe
     (Bool |? (DeclarationOptions |? DeclarationRegistrationOptions))
forall {t :: MessageKind} {m :: Method 'ClientToServer t} {a}.
SClientMethod @t m -> a -> Maybe a
supported' SClientMethod @'Request 'Method_TextDocumentDeclaration
SMethod_TextDocumentDeclaration ((Bool |? (DeclarationOptions |? DeclarationRegistrationOptions))
 -> Maybe
      (Bool |? (DeclarationOptions |? DeclarationRegistrationOptions)))
-> (Bool |? (DeclarationOptions |? DeclarationRegistrationOptions))
-> Maybe
     (Bool |? (DeclarationOptions |? DeclarationRegistrationOptions))
forall a b. (a -> b) -> a -> b
$
          (DeclarationOptions |? DeclarationRegistrationOptions)
-> Bool |? (DeclarationOptions |? DeclarationRegistrationOptions)
forall a b. b -> a |? b
InR ((DeclarationOptions |? DeclarationRegistrationOptions)
 -> Bool |? (DeclarationOptions |? DeclarationRegistrationOptions))
-> (DeclarationOptions |? DeclarationRegistrationOptions)
-> Bool |? (DeclarationOptions |? DeclarationRegistrationOptions)
forall a b. (a -> b) -> a -> b
$
            DeclarationOptions
-> DeclarationOptions |? DeclarationRegistrationOptions
forall a b. a -> a |? b
InL (DeclarationOptions
 -> DeclarationOptions |? DeclarationRegistrationOptions)
-> DeclarationOptions
-> DeclarationOptions |? DeclarationRegistrationOptions
forall a b. (a -> b) -> a -> b
$
              Maybe Bool -> DeclarationOptions
DeclarationOptions Maybe Bool
clientInitiatedProgress
    , _signatureHelpProvider :: Maybe SignatureHelpOptions
_signatureHelpProvider = Maybe SignatureHelpOptions
signatureHelpProvider
    , _definitionProvider :: Maybe (Bool |? DefinitionOptions)
_definitionProvider =
        SClientMethod @'Request 'Method_TextDocumentDefinition
-> (Bool |? DefinitionOptions) -> Maybe (Bool |? DefinitionOptions)
forall {t :: MessageKind} {m :: Method 'ClientToServer t} {a}.
SClientMethod @t m -> a -> Maybe a
supported' SClientMethod @'Request 'Method_TextDocumentDefinition
SMethod_TextDocumentDefinition ((Bool |? DefinitionOptions) -> Maybe (Bool |? DefinitionOptions))
-> (Bool |? DefinitionOptions) -> Maybe (Bool |? DefinitionOptions)
forall a b. (a -> b) -> a -> b
$
          DefinitionOptions -> Bool |? DefinitionOptions
forall a b. b -> a |? b
InR (DefinitionOptions -> Bool |? DefinitionOptions)
-> DefinitionOptions -> Bool |? DefinitionOptions
forall a b. (a -> b) -> a -> b
$
            Maybe Bool -> DefinitionOptions
DefinitionOptions Maybe Bool
clientInitiatedProgress
    , _typeDefinitionProvider :: Maybe
  (Bool
   |? (TypeDefinitionOptions |? TypeDefinitionRegistrationOptions))
_typeDefinitionProvider =
        SClientMethod @'Request 'Method_TextDocumentTypeDefinition
-> (Bool
    |? (TypeDefinitionOptions |? TypeDefinitionRegistrationOptions))
-> Maybe
     (Bool
      |? (TypeDefinitionOptions |? TypeDefinitionRegistrationOptions))
forall {t :: MessageKind} {m :: Method 'ClientToServer t} {a}.
SClientMethod @t m -> a -> Maybe a
supported' SClientMethod @'Request 'Method_TextDocumentTypeDefinition
SMethod_TextDocumentTypeDefinition ((Bool
  |? (TypeDefinitionOptions |? TypeDefinitionRegistrationOptions))
 -> Maybe
      (Bool
       |? (TypeDefinitionOptions |? TypeDefinitionRegistrationOptions)))
-> (Bool
    |? (TypeDefinitionOptions |? TypeDefinitionRegistrationOptions))
-> Maybe
     (Bool
      |? (TypeDefinitionOptions |? TypeDefinitionRegistrationOptions))
forall a b. (a -> b) -> a -> b
$
          (TypeDefinitionOptions |? TypeDefinitionRegistrationOptions)
-> Bool
   |? (TypeDefinitionOptions |? TypeDefinitionRegistrationOptions)
forall a b. b -> a |? b
InR ((TypeDefinitionOptions |? TypeDefinitionRegistrationOptions)
 -> Bool
    |? (TypeDefinitionOptions |? TypeDefinitionRegistrationOptions))
-> (TypeDefinitionOptions |? TypeDefinitionRegistrationOptions)
-> Bool
   |? (TypeDefinitionOptions |? TypeDefinitionRegistrationOptions)
forall a b. (a -> b) -> a -> b
$
            TypeDefinitionOptions
-> TypeDefinitionOptions |? TypeDefinitionRegistrationOptions
forall a b. a -> a |? b
InL (TypeDefinitionOptions
 -> TypeDefinitionOptions |? TypeDefinitionRegistrationOptions)
-> TypeDefinitionOptions
-> TypeDefinitionOptions |? TypeDefinitionRegistrationOptions
forall a b. (a -> b) -> a -> b
$
              Maybe Bool -> TypeDefinitionOptions
TypeDefinitionOptions Maybe Bool
clientInitiatedProgress
    , _implementationProvider :: Maybe
  (Bool
   |? (ImplementationOptions |? ImplementationRegistrationOptions))
_implementationProvider =
        SClientMethod @'Request 'Method_TextDocumentImplementation
-> (Bool
    |? (ImplementationOptions |? ImplementationRegistrationOptions))
-> Maybe
     (Bool
      |? (ImplementationOptions |? ImplementationRegistrationOptions))
forall {t :: MessageKind} {m :: Method 'ClientToServer t} {a}.
SClientMethod @t m -> a -> Maybe a
supported' SClientMethod @'Request 'Method_TextDocumentImplementation
SMethod_TextDocumentImplementation ((Bool
  |? (ImplementationOptions |? ImplementationRegistrationOptions))
 -> Maybe
      (Bool
       |? (ImplementationOptions |? ImplementationRegistrationOptions)))
-> (Bool
    |? (ImplementationOptions |? ImplementationRegistrationOptions))
-> Maybe
     (Bool
      |? (ImplementationOptions |? ImplementationRegistrationOptions))
forall a b. (a -> b) -> a -> b
$
          (ImplementationOptions |? ImplementationRegistrationOptions)
-> Bool
   |? (ImplementationOptions |? ImplementationRegistrationOptions)
forall a b. b -> a |? b
InR ((ImplementationOptions |? ImplementationRegistrationOptions)
 -> Bool
    |? (ImplementationOptions |? ImplementationRegistrationOptions))
-> (ImplementationOptions |? ImplementationRegistrationOptions)
-> Bool
   |? (ImplementationOptions |? ImplementationRegistrationOptions)
forall a b. (a -> b) -> a -> b
$
            ImplementationOptions
-> ImplementationOptions |? ImplementationRegistrationOptions
forall a b. a -> a |? b
InL (ImplementationOptions
 -> ImplementationOptions |? ImplementationRegistrationOptions)
-> ImplementationOptions
-> ImplementationOptions |? ImplementationRegistrationOptions
forall a b. (a -> b) -> a -> b
$
              Maybe Bool -> ImplementationOptions
ImplementationOptions Maybe Bool
clientInitiatedProgress
    , _referencesProvider :: Maybe (Bool |? ReferenceOptions)
_referencesProvider =
        SClientMethod @'Request 'Method_TextDocumentReferences
-> (Bool |? ReferenceOptions) -> Maybe (Bool |? ReferenceOptions)
forall {t :: MessageKind} {m :: Method 'ClientToServer t} {a}.
SClientMethod @t m -> a -> Maybe a
supported' SClientMethod @'Request 'Method_TextDocumentReferences
SMethod_TextDocumentReferences ((Bool |? ReferenceOptions) -> Maybe (Bool |? ReferenceOptions))
-> (Bool |? ReferenceOptions) -> Maybe (Bool |? ReferenceOptions)
forall a b. (a -> b) -> a -> b
$
          ReferenceOptions -> Bool |? ReferenceOptions
forall a b. b -> a |? b
InR (ReferenceOptions -> Bool |? ReferenceOptions)
-> ReferenceOptions -> Bool |? ReferenceOptions
forall a b. (a -> b) -> a -> b
$
            Maybe Bool -> ReferenceOptions
ReferenceOptions Maybe Bool
clientInitiatedProgress
    , _documentHighlightProvider :: Maybe (Bool |? DocumentHighlightOptions)
_documentHighlightProvider =
        SClientMethod @'Request 'Method_TextDocumentDocumentHighlight
-> (Bool |? DocumentHighlightOptions)
-> Maybe (Bool |? DocumentHighlightOptions)
forall {t :: MessageKind} {m :: Method 'ClientToServer t} {a}.
SClientMethod @t m -> a -> Maybe a
supported' SClientMethod @'Request 'Method_TextDocumentDocumentHighlight
SMethod_TextDocumentDocumentHighlight ((Bool |? DocumentHighlightOptions)
 -> Maybe (Bool |? DocumentHighlightOptions))
-> (Bool |? DocumentHighlightOptions)
-> Maybe (Bool |? DocumentHighlightOptions)
forall a b. (a -> b) -> a -> b
$
          DocumentHighlightOptions -> Bool |? DocumentHighlightOptions
forall a b. b -> a |? b
InR (DocumentHighlightOptions -> Bool |? DocumentHighlightOptions)
-> DocumentHighlightOptions -> Bool |? DocumentHighlightOptions
forall a b. (a -> b) -> a -> b
$
            Maybe Bool -> DocumentHighlightOptions
DocumentHighlightOptions Maybe Bool
clientInitiatedProgress
    , _documentSymbolProvider :: Maybe (Bool |? DocumentSymbolOptions)
_documentSymbolProvider =
        SClientMethod @'Request 'Method_TextDocumentDocumentSymbol
-> (Bool |? DocumentSymbolOptions)
-> Maybe (Bool |? DocumentSymbolOptions)
forall {t :: MessageKind} {m :: Method 'ClientToServer t} {a}.
SClientMethod @t m -> a -> Maybe a
supported' SClientMethod @'Request 'Method_TextDocumentDocumentSymbol
SMethod_TextDocumentDocumentSymbol ((Bool |? DocumentSymbolOptions)
 -> Maybe (Bool |? DocumentSymbolOptions))
-> (Bool |? DocumentSymbolOptions)
-> Maybe (Bool |? DocumentSymbolOptions)
forall a b. (a -> b) -> a -> b
$
          DocumentSymbolOptions -> Bool |? DocumentSymbolOptions
forall a b. b -> a |? b
InR (DocumentSymbolOptions -> Bool |? DocumentSymbolOptions)
-> DocumentSymbolOptions -> Bool |? DocumentSymbolOptions
forall a b. (a -> b) -> a -> b
$
            Maybe Bool -> Maybe Text -> DocumentSymbolOptions
DocumentSymbolOptions Maybe Bool
clientInitiatedProgress Maybe Text
forall a. Maybe a
Nothing
    , _codeActionProvider :: Maybe (Bool |? CodeActionOptions)
_codeActionProvider = Maybe (Bool |? CodeActionOptions)
codeActionProvider
    , _codeLensProvider :: Maybe CodeLensOptions
_codeLensProvider =
        SClientMethod @'Request 'Method_TextDocumentCodeLens
-> CodeLensOptions -> Maybe CodeLensOptions
forall {t :: MessageKind} {m :: Method 'ClientToServer t} {a}.
SClientMethod @t m -> a -> Maybe a
supported' SClientMethod @'Request 'Method_TextDocumentCodeLens
SMethod_TextDocumentCodeLens (CodeLensOptions -> Maybe CodeLensOptions)
-> CodeLensOptions -> Maybe CodeLensOptions
forall a b. (a -> b) -> a -> b
$
          Maybe Bool -> Maybe Bool -> CodeLensOptions
CodeLensOptions Maybe Bool
clientInitiatedProgress (SClientMethod @'Request 'Method_CodeLensResolve -> Maybe Bool
forall {t :: MessageKind} (m :: Method 'ClientToServer t).
SClientMethod @t m -> Maybe Bool
supported SClientMethod @'Request 'Method_CodeLensResolve
SMethod_CodeLensResolve)
    , _documentFormattingProvider :: Maybe (Bool |? DocumentFormattingOptions)
_documentFormattingProvider =
        SClientMethod @'Request 'Method_TextDocumentFormatting
-> (Bool |? DocumentFormattingOptions)
-> Maybe (Bool |? DocumentFormattingOptions)
forall {t :: MessageKind} {m :: Method 'ClientToServer t} {a}.
SClientMethod @t m -> a -> Maybe a
supported' SClientMethod @'Request 'Method_TextDocumentFormatting
SMethod_TextDocumentFormatting ((Bool |? DocumentFormattingOptions)
 -> Maybe (Bool |? DocumentFormattingOptions))
-> (Bool |? DocumentFormattingOptions)
-> Maybe (Bool |? DocumentFormattingOptions)
forall a b. (a -> b) -> a -> b
$
          DocumentFormattingOptions -> Bool |? DocumentFormattingOptions
forall a b. b -> a |? b
InR (DocumentFormattingOptions -> Bool |? DocumentFormattingOptions)
-> DocumentFormattingOptions -> Bool |? DocumentFormattingOptions
forall a b. (a -> b) -> a -> b
$
            Maybe Bool -> DocumentFormattingOptions
DocumentFormattingOptions Maybe Bool
clientInitiatedProgress
    , _documentRangeFormattingProvider :: Maybe (Bool |? DocumentRangeFormattingOptions)
_documentRangeFormattingProvider =
        SClientMethod @'Request 'Method_TextDocumentRangeFormatting
-> (Bool |? DocumentRangeFormattingOptions)
-> Maybe (Bool |? DocumentRangeFormattingOptions)
forall {t :: MessageKind} {m :: Method 'ClientToServer t} {a}.
SClientMethod @t m -> a -> Maybe a
supported' SClientMethod @'Request 'Method_TextDocumentRangeFormatting
SMethod_TextDocumentRangeFormatting ((Bool |? DocumentRangeFormattingOptions)
 -> Maybe (Bool |? DocumentRangeFormattingOptions))
-> (Bool |? DocumentRangeFormattingOptions)
-> Maybe (Bool |? DocumentRangeFormattingOptions)
forall a b. (a -> b) -> a -> b
$
          DocumentRangeFormattingOptions
-> Bool |? DocumentRangeFormattingOptions
forall a b. b -> a |? b
InR (DocumentRangeFormattingOptions
 -> Bool |? DocumentRangeFormattingOptions)
-> DocumentRangeFormattingOptions
-> Bool |? DocumentRangeFormattingOptions
forall a b. (a -> b) -> a -> b
$
            Maybe Bool -> DocumentRangeFormattingOptions
DocumentRangeFormattingOptions Maybe Bool
clientInitiatedProgress
    , _documentOnTypeFormattingProvider :: Maybe DocumentOnTypeFormattingOptions
_documentOnTypeFormattingProvider = Maybe DocumentOnTypeFormattingOptions
documentOnTypeFormattingProvider
    , _renameProvider :: Maybe (Bool |? RenameOptions)
_renameProvider =
        SClientMethod @'Request 'Method_TextDocumentRename
-> (Bool |? RenameOptions) -> Maybe (Bool |? RenameOptions)
forall {t :: MessageKind} {m :: Method 'ClientToServer t} {a}.
SClientMethod @t m -> a -> Maybe a
supported' SClientMethod @'Request 'Method_TextDocumentRename
SMethod_TextDocumentRename ((Bool |? RenameOptions) -> Maybe (Bool |? RenameOptions))
-> (Bool |? RenameOptions) -> Maybe (Bool |? RenameOptions)
forall a b. (a -> b) -> a -> b
$
          RenameOptions -> Bool |? RenameOptions
forall a b. b -> a |? b
InR (RenameOptions -> Bool |? RenameOptions)
-> RenameOptions -> Bool |? RenameOptions
forall a b. (a -> b) -> a -> b
$
            Maybe Bool -> Maybe Bool -> RenameOptions
RenameOptions Maybe Bool
clientInitiatedProgress (SClientMethod @'Request 'Method_TextDocumentPrepareRename
-> Maybe Bool
forall {t :: MessageKind} (m :: Method 'ClientToServer t).
SClientMethod @t m -> Maybe Bool
supported SClientMethod @'Request 'Method_TextDocumentPrepareRename
SMethod_TextDocumentPrepareRename)
    , _documentLinkProvider :: Maybe DocumentLinkOptions
_documentLinkProvider =
        SClientMethod @'Request 'Method_TextDocumentDocumentLink
-> DocumentLinkOptions -> Maybe DocumentLinkOptions
forall {t :: MessageKind} {m :: Method 'ClientToServer t} {a}.
SClientMethod @t m -> a -> Maybe a
supported' SClientMethod @'Request 'Method_TextDocumentDocumentLink
SMethod_TextDocumentDocumentLink (DocumentLinkOptions -> Maybe DocumentLinkOptions)
-> DocumentLinkOptions -> Maybe DocumentLinkOptions
forall a b. (a -> b) -> a -> b
$
          Maybe Bool -> Maybe Bool -> DocumentLinkOptions
DocumentLinkOptions Maybe Bool
clientInitiatedProgress (SClientMethod @'Request 'Method_DocumentLinkResolve -> Maybe Bool
forall {t :: MessageKind} (m :: Method 'ClientToServer t).
SClientMethod @t m -> Maybe Bool
supported SClientMethod @'Request 'Method_DocumentLinkResolve
SMethod_DocumentLinkResolve)
    , _colorProvider :: Maybe
  (Bool
   |? (DocumentColorOptions |? DocumentColorRegistrationOptions))
_colorProvider =
        SClientMethod @'Request 'Method_TextDocumentDocumentColor
-> (Bool
    |? (DocumentColorOptions |? DocumentColorRegistrationOptions))
-> Maybe
     (Bool
      |? (DocumentColorOptions |? DocumentColorRegistrationOptions))
forall {t :: MessageKind} {m :: Method 'ClientToServer t} {a}.
SClientMethod @t m -> a -> Maybe a
supported' SClientMethod @'Request 'Method_TextDocumentDocumentColor
SMethod_TextDocumentDocumentColor ((Bool
  |? (DocumentColorOptions |? DocumentColorRegistrationOptions))
 -> Maybe
      (Bool
       |? (DocumentColorOptions |? DocumentColorRegistrationOptions)))
-> (Bool
    |? (DocumentColorOptions |? DocumentColorRegistrationOptions))
-> Maybe
     (Bool
      |? (DocumentColorOptions |? DocumentColorRegistrationOptions))
forall a b. (a -> b) -> a -> b
$
          (DocumentColorOptions |? DocumentColorRegistrationOptions)
-> Bool
   |? (DocumentColorOptions |? DocumentColorRegistrationOptions)
forall a b. b -> a |? b
InR ((DocumentColorOptions |? DocumentColorRegistrationOptions)
 -> Bool
    |? (DocumentColorOptions |? DocumentColorRegistrationOptions))
-> (DocumentColorOptions |? DocumentColorRegistrationOptions)
-> Bool
   |? (DocumentColorOptions |? DocumentColorRegistrationOptions)
forall a b. (a -> b) -> a -> b
$
            DocumentColorOptions
-> DocumentColorOptions |? DocumentColorRegistrationOptions
forall a b. a -> a |? b
InL (DocumentColorOptions
 -> DocumentColorOptions |? DocumentColorRegistrationOptions)
-> DocumentColorOptions
-> DocumentColorOptions |? DocumentColorRegistrationOptions
forall a b. (a -> b) -> a -> b
$
              Maybe Bool -> DocumentColorOptions
DocumentColorOptions Maybe Bool
clientInitiatedProgress
    , _foldingRangeProvider :: Maybe
  (Bool |? (FoldingRangeOptions |? FoldingRangeRegistrationOptions))
_foldingRangeProvider =
        SClientMethod @'Request 'Method_TextDocumentFoldingRange
-> (Bool
    |? (FoldingRangeOptions |? FoldingRangeRegistrationOptions))
-> Maybe
     (Bool |? (FoldingRangeOptions |? FoldingRangeRegistrationOptions))
forall {t :: MessageKind} {m :: Method 'ClientToServer t} {a}.
SClientMethod @t m -> a -> Maybe a
supported' SClientMethod @'Request 'Method_TextDocumentFoldingRange
SMethod_TextDocumentFoldingRange ((Bool |? (FoldingRangeOptions |? FoldingRangeRegistrationOptions))
 -> Maybe
      (Bool |? (FoldingRangeOptions |? FoldingRangeRegistrationOptions)))
-> (Bool
    |? (FoldingRangeOptions |? FoldingRangeRegistrationOptions))
-> Maybe
     (Bool |? (FoldingRangeOptions |? FoldingRangeRegistrationOptions))
forall a b. (a -> b) -> a -> b
$
          (FoldingRangeOptions |? FoldingRangeRegistrationOptions)
-> Bool |? (FoldingRangeOptions |? FoldingRangeRegistrationOptions)
forall a b. b -> a |? b
InR ((FoldingRangeOptions |? FoldingRangeRegistrationOptions)
 -> Bool
    |? (FoldingRangeOptions |? FoldingRangeRegistrationOptions))
-> (FoldingRangeOptions |? FoldingRangeRegistrationOptions)
-> Bool |? (FoldingRangeOptions |? FoldingRangeRegistrationOptions)
forall a b. (a -> b) -> a -> b
$
            FoldingRangeOptions
-> FoldingRangeOptions |? FoldingRangeRegistrationOptions
forall a b. a -> a |? b
InL (FoldingRangeOptions
 -> FoldingRangeOptions |? FoldingRangeRegistrationOptions)
-> FoldingRangeOptions
-> FoldingRangeOptions |? FoldingRangeRegistrationOptions
forall a b. (a -> b) -> a -> b
$
              Maybe Bool -> FoldingRangeOptions
FoldingRangeOptions Maybe Bool
clientInitiatedProgress
    , _executeCommandProvider :: Maybe ExecuteCommandOptions
_executeCommandProvider = Maybe ExecuteCommandOptions
executeCommandProvider
    , _selectionRangeProvider :: Maybe
  (Bool
   |? (SelectionRangeOptions |? SelectionRangeRegistrationOptions))
_selectionRangeProvider =
        SClientMethod @'Request 'Method_TextDocumentSelectionRange
-> (Bool
    |? (SelectionRangeOptions |? SelectionRangeRegistrationOptions))
-> Maybe
     (Bool
      |? (SelectionRangeOptions |? SelectionRangeRegistrationOptions))
forall {t :: MessageKind} {m :: Method 'ClientToServer t} {a}.
SClientMethod @t m -> a -> Maybe a
supported' SClientMethod @'Request 'Method_TextDocumentSelectionRange
SMethod_TextDocumentSelectionRange ((Bool
  |? (SelectionRangeOptions |? SelectionRangeRegistrationOptions))
 -> Maybe
      (Bool
       |? (SelectionRangeOptions |? SelectionRangeRegistrationOptions)))
-> (Bool
    |? (SelectionRangeOptions |? SelectionRangeRegistrationOptions))
-> Maybe
     (Bool
      |? (SelectionRangeOptions |? SelectionRangeRegistrationOptions))
forall a b. (a -> b) -> a -> b
$
          (SelectionRangeOptions |? SelectionRangeRegistrationOptions)
-> Bool
   |? (SelectionRangeOptions |? SelectionRangeRegistrationOptions)
forall a b. b -> a |? b
InR ((SelectionRangeOptions |? SelectionRangeRegistrationOptions)
 -> Bool
    |? (SelectionRangeOptions |? SelectionRangeRegistrationOptions))
-> (SelectionRangeOptions |? SelectionRangeRegistrationOptions)
-> Bool
   |? (SelectionRangeOptions |? SelectionRangeRegistrationOptions)
forall a b. (a -> b) -> a -> b
$
            SelectionRangeOptions
-> SelectionRangeOptions |? SelectionRangeRegistrationOptions
forall a b. a -> a |? b
InL (SelectionRangeOptions
 -> SelectionRangeOptions |? SelectionRangeRegistrationOptions)
-> SelectionRangeOptions
-> SelectionRangeOptions |? SelectionRangeRegistrationOptions
forall a b. (a -> b) -> a -> b
$
              Maybe Bool -> SelectionRangeOptions
SelectionRangeOptions Maybe Bool
clientInitiatedProgress
    , _callHierarchyProvider :: Maybe
  (Bool
   |? (CallHierarchyOptions |? CallHierarchyRegistrationOptions))
_callHierarchyProvider =
        SClientMethod @'Request 'Method_TextDocumentPrepareCallHierarchy
-> (Bool
    |? (CallHierarchyOptions |? CallHierarchyRegistrationOptions))
-> Maybe
     (Bool
      |? (CallHierarchyOptions |? CallHierarchyRegistrationOptions))
forall {t :: MessageKind} {m :: Method 'ClientToServer t} {a}.
SClientMethod @t m -> a -> Maybe a
supported' SClientMethod @'Request 'Method_TextDocumentPrepareCallHierarchy
SMethod_TextDocumentPrepareCallHierarchy ((Bool
  |? (CallHierarchyOptions |? CallHierarchyRegistrationOptions))
 -> Maybe
      (Bool
       |? (CallHierarchyOptions |? CallHierarchyRegistrationOptions)))
-> (Bool
    |? (CallHierarchyOptions |? CallHierarchyRegistrationOptions))
-> Maybe
     (Bool
      |? (CallHierarchyOptions |? CallHierarchyRegistrationOptions))
forall a b. (a -> b) -> a -> b
$
          (CallHierarchyOptions |? CallHierarchyRegistrationOptions)
-> Bool
   |? (CallHierarchyOptions |? CallHierarchyRegistrationOptions)
forall a b. b -> a |? b
InR ((CallHierarchyOptions |? CallHierarchyRegistrationOptions)
 -> Bool
    |? (CallHierarchyOptions |? CallHierarchyRegistrationOptions))
-> (CallHierarchyOptions |? CallHierarchyRegistrationOptions)
-> Bool
   |? (CallHierarchyOptions |? CallHierarchyRegistrationOptions)
forall a b. (a -> b) -> a -> b
$
            CallHierarchyOptions
-> CallHierarchyOptions |? CallHierarchyRegistrationOptions
forall a b. a -> a |? b
InL (CallHierarchyOptions
 -> CallHierarchyOptions |? CallHierarchyRegistrationOptions)
-> CallHierarchyOptions
-> CallHierarchyOptions |? CallHierarchyRegistrationOptions
forall a b. (a -> b) -> a -> b
$
              Maybe Bool -> CallHierarchyOptions
CallHierarchyOptions Maybe Bool
clientInitiatedProgress
    , _semanticTokensProvider :: Maybe (SemanticTokensOptions |? SemanticTokensRegistrationOptions)
_semanticTokensProvider = Maybe (SemanticTokensOptions |? SemanticTokensRegistrationOptions)
semanticTokensProvider
    , _workspaceSymbolProvider :: Maybe (Bool |? WorkspaceSymbolOptions)
_workspaceSymbolProvider =
        SClientMethod @'Request 'Method_WorkspaceSymbol
-> (Bool |? WorkspaceSymbolOptions)
-> Maybe (Bool |? WorkspaceSymbolOptions)
forall {t :: MessageKind} {m :: Method 'ClientToServer t} {a}.
SClientMethod @t m -> a -> Maybe a
supported' SClientMethod @'Request 'Method_WorkspaceSymbol
SMethod_WorkspaceSymbol ((Bool |? WorkspaceSymbolOptions)
 -> Maybe (Bool |? WorkspaceSymbolOptions))
-> (Bool |? WorkspaceSymbolOptions)
-> Maybe (Bool |? WorkspaceSymbolOptions)
forall a b. (a -> b) -> a -> b
$
          WorkspaceSymbolOptions -> Bool |? WorkspaceSymbolOptions
forall a b. b -> a |? b
InR (WorkspaceSymbolOptions -> Bool |? WorkspaceSymbolOptions)
-> WorkspaceSymbolOptions -> Bool |? WorkspaceSymbolOptions
forall a b. (a -> b) -> a -> b
$
            Maybe Bool -> Maybe Bool -> WorkspaceSymbolOptions
WorkspaceSymbolOptions Maybe Bool
clientInitiatedProgress (SClientMethod @'Request 'Method_WorkspaceSymbolResolve
-> Maybe Bool
forall {t :: MessageKind} (m :: Method 'ClientToServer t).
SClientMethod @t m -> Maybe Bool
supported SClientMethod @'Request 'Method_WorkspaceSymbolResolve
SMethod_WorkspaceSymbolResolve)
    , _workspace :: Maybe WorkspaceOptions
_workspace = WorkspaceOptions -> Maybe WorkspaceOptions
forall a. a -> Maybe a
Just WorkspaceOptions
workspace
    , _experimental :: Maybe Value
_experimental = Maybe Value
forall a. Maybe a
Nothing :: Maybe Value
    , -- The only encoding the VFS supports is the legacy UTF16 option at the moment
      _positionEncoding :: Maybe PositionEncodingKind
_positionEncoding = PositionEncodingKind -> Maybe PositionEncodingKind
forall a. a -> Maybe a
Just PositionEncodingKind
PositionEncodingKind_UTF16
    , _linkedEditingRangeProvider :: Maybe
  (Bool
   |? (LinkedEditingRangeOptions
       |? LinkedEditingRangeRegistrationOptions))
_linkedEditingRangeProvider =
        SClientMethod @'Request 'Method_TextDocumentLinkedEditingRange
-> (Bool
    |? (LinkedEditingRangeOptions
        |? LinkedEditingRangeRegistrationOptions))
-> Maybe
     (Bool
      |? (LinkedEditingRangeOptions
          |? LinkedEditingRangeRegistrationOptions))
forall {t :: MessageKind} {m :: Method 'ClientToServer t} {a}.
SClientMethod @t m -> a -> Maybe a
supported' SClientMethod @'Request 'Method_TextDocumentLinkedEditingRange
SMethod_TextDocumentLinkedEditingRange ((Bool
  |? (LinkedEditingRangeOptions
      |? LinkedEditingRangeRegistrationOptions))
 -> Maybe
      (Bool
       |? (LinkedEditingRangeOptions
           |? LinkedEditingRangeRegistrationOptions)))
-> (Bool
    |? (LinkedEditingRangeOptions
        |? LinkedEditingRangeRegistrationOptions))
-> Maybe
     (Bool
      |? (LinkedEditingRangeOptions
          |? LinkedEditingRangeRegistrationOptions))
forall a b. (a -> b) -> a -> b
$
          (LinkedEditingRangeOptions
 |? LinkedEditingRangeRegistrationOptions)
-> Bool
   |? (LinkedEditingRangeOptions
       |? LinkedEditingRangeRegistrationOptions)
forall a b. b -> a |? b
InR ((LinkedEditingRangeOptions
  |? LinkedEditingRangeRegistrationOptions)
 -> Bool
    |? (LinkedEditingRangeOptions
        |? LinkedEditingRangeRegistrationOptions))
-> (LinkedEditingRangeOptions
    |? LinkedEditingRangeRegistrationOptions)
-> Bool
   |? (LinkedEditingRangeOptions
       |? LinkedEditingRangeRegistrationOptions)
forall a b. (a -> b) -> a -> b
$
            LinkedEditingRangeOptions
-> LinkedEditingRangeOptions
   |? LinkedEditingRangeRegistrationOptions
forall a b. a -> a |? b
InL (LinkedEditingRangeOptions
 -> LinkedEditingRangeOptions
    |? LinkedEditingRangeRegistrationOptions)
-> LinkedEditingRangeOptions
-> LinkedEditingRangeOptions
   |? LinkedEditingRangeRegistrationOptions
forall a b. (a -> b) -> a -> b
$
              Maybe Bool -> LinkedEditingRangeOptions
LinkedEditingRangeOptions Maybe Bool
clientInitiatedProgress
    , _monikerProvider :: Maybe (Bool |? (MonikerOptions |? MonikerRegistrationOptions))
_monikerProvider =
        SClientMethod @'Request 'Method_TextDocumentMoniker
-> (Bool |? (MonikerOptions |? MonikerRegistrationOptions))
-> Maybe (Bool |? (MonikerOptions |? MonikerRegistrationOptions))
forall {t :: MessageKind} {m :: Method 'ClientToServer t} {a}.
SClientMethod @t m -> a -> Maybe a
supported' SClientMethod @'Request 'Method_TextDocumentMoniker
SMethod_TextDocumentMoniker ((Bool |? (MonikerOptions |? MonikerRegistrationOptions))
 -> Maybe (Bool |? (MonikerOptions |? MonikerRegistrationOptions)))
-> (Bool |? (MonikerOptions |? MonikerRegistrationOptions))
-> Maybe (Bool |? (MonikerOptions |? MonikerRegistrationOptions))
forall a b. (a -> b) -> a -> b
$
          (MonikerOptions |? MonikerRegistrationOptions)
-> Bool |? (MonikerOptions |? MonikerRegistrationOptions)
forall a b. b -> a |? b
InR ((MonikerOptions |? MonikerRegistrationOptions)
 -> Bool |? (MonikerOptions |? MonikerRegistrationOptions))
-> (MonikerOptions |? MonikerRegistrationOptions)
-> Bool |? (MonikerOptions |? MonikerRegistrationOptions)
forall a b. (a -> b) -> a -> b
$
            MonikerOptions -> MonikerOptions |? MonikerRegistrationOptions
forall a b. a -> a |? b
InL (MonikerOptions -> MonikerOptions |? MonikerRegistrationOptions)
-> MonikerOptions -> MonikerOptions |? MonikerRegistrationOptions
forall a b. (a -> b) -> a -> b
$
              Maybe Bool -> MonikerOptions
MonikerOptions Maybe Bool
clientInitiatedProgress
    , _typeHierarchyProvider :: Maybe
  (Bool
   |? (TypeHierarchyOptions |? TypeHierarchyRegistrationOptions))
_typeHierarchyProvider =
        SClientMethod @'Request 'Method_TextDocumentPrepareTypeHierarchy
-> (Bool
    |? (TypeHierarchyOptions |? TypeHierarchyRegistrationOptions))
-> Maybe
     (Bool
      |? (TypeHierarchyOptions |? TypeHierarchyRegistrationOptions))
forall {t :: MessageKind} {m :: Method 'ClientToServer t} {a}.
SClientMethod @t m -> a -> Maybe a
supported' SClientMethod @'Request 'Method_TextDocumentPrepareTypeHierarchy
SMethod_TextDocumentPrepareTypeHierarchy ((Bool
  |? (TypeHierarchyOptions |? TypeHierarchyRegistrationOptions))
 -> Maybe
      (Bool
       |? (TypeHierarchyOptions |? TypeHierarchyRegistrationOptions)))
-> (Bool
    |? (TypeHierarchyOptions |? TypeHierarchyRegistrationOptions))
-> Maybe
     (Bool
      |? (TypeHierarchyOptions |? TypeHierarchyRegistrationOptions))
forall a b. (a -> b) -> a -> b
$
          (TypeHierarchyOptions |? TypeHierarchyRegistrationOptions)
-> Bool
   |? (TypeHierarchyOptions |? TypeHierarchyRegistrationOptions)
forall a b. b -> a |? b
InR ((TypeHierarchyOptions |? TypeHierarchyRegistrationOptions)
 -> Bool
    |? (TypeHierarchyOptions |? TypeHierarchyRegistrationOptions))
-> (TypeHierarchyOptions |? TypeHierarchyRegistrationOptions)
-> Bool
   |? (TypeHierarchyOptions |? TypeHierarchyRegistrationOptions)
forall a b. (a -> b) -> a -> b
$
            TypeHierarchyOptions
-> TypeHierarchyOptions |? TypeHierarchyRegistrationOptions
forall a b. a -> a |? b
InL (TypeHierarchyOptions
 -> TypeHierarchyOptions |? TypeHierarchyRegistrationOptions)
-> TypeHierarchyOptions
-> TypeHierarchyOptions |? TypeHierarchyRegistrationOptions
forall a b. (a -> b) -> a -> b
$
              Maybe Bool -> TypeHierarchyOptions
TypeHierarchyOptions Maybe Bool
clientInitiatedProgress
    , _inlineValueProvider :: Maybe
  (Bool |? (InlineValueOptions |? InlineValueRegistrationOptions))
_inlineValueProvider =
        SClientMethod @'Request 'Method_TextDocumentInlineValue
-> (Bool |? (InlineValueOptions |? InlineValueRegistrationOptions))
-> Maybe
     (Bool |? (InlineValueOptions |? InlineValueRegistrationOptions))
forall {t :: MessageKind} {m :: Method 'ClientToServer t} {a}.
SClientMethod @t m -> a -> Maybe a
supported' SClientMethod @'Request 'Method_TextDocumentInlineValue
SMethod_TextDocumentInlineValue ((Bool |? (InlineValueOptions |? InlineValueRegistrationOptions))
 -> Maybe
      (Bool |? (InlineValueOptions |? InlineValueRegistrationOptions)))
-> (Bool |? (InlineValueOptions |? InlineValueRegistrationOptions))
-> Maybe
     (Bool |? (InlineValueOptions |? InlineValueRegistrationOptions))
forall a b. (a -> b) -> a -> b
$
          (InlineValueOptions |? InlineValueRegistrationOptions)
-> Bool |? (InlineValueOptions |? InlineValueRegistrationOptions)
forall a b. b -> a |? b
InR ((InlineValueOptions |? InlineValueRegistrationOptions)
 -> Bool |? (InlineValueOptions |? InlineValueRegistrationOptions))
-> (InlineValueOptions |? InlineValueRegistrationOptions)
-> Bool |? (InlineValueOptions |? InlineValueRegistrationOptions)
forall a b. (a -> b) -> a -> b
$
            InlineValueOptions
-> InlineValueOptions |? InlineValueRegistrationOptions
forall a b. a -> a |? b
InL (InlineValueOptions
 -> InlineValueOptions |? InlineValueRegistrationOptions)
-> InlineValueOptions
-> InlineValueOptions |? InlineValueRegistrationOptions
forall a b. (a -> b) -> a -> b
$
              Maybe Bool -> InlineValueOptions
InlineValueOptions Maybe Bool
clientInitiatedProgress
    , _diagnosticProvider :: Maybe (DiagnosticOptions |? DiagnosticRegistrationOptions)
_diagnosticProvider = Maybe (DiagnosticOptions |? DiagnosticRegistrationOptions)
diagnosticProvider
    , -- TODO: super unclear what to do about notebooks in general
      _notebookDocumentSync :: Maybe
  (NotebookDocumentSyncOptions
   |? NotebookDocumentSyncRegistrationOptions)
_notebookDocumentSync = Maybe
  (NotebookDocumentSyncOptions
   |? NotebookDocumentSyncRegistrationOptions)
forall a. Maybe a
Nothing
    }
 where
  clientInitiatedProgress :: Maybe Bool
clientInitiatedProgress = Bool -> Maybe Bool
forall a. a -> Maybe a
Just (Options -> Bool
optSupportClientInitiatedProgress Options
o)

  supported' :: SClientMethod @t m -> a -> Maybe a
supported' SClientMethod @t m
m a
b
    | SClientMethod @t m -> Bool
forall {t :: MessageKind} (m :: Method 'ClientToServer t).
SClientMethod @t m -> Bool
supported_b SClientMethod @t m
m = a -> Maybe a
forall a. a -> Maybe a
Just a
b
    | Bool
otherwise = Maybe a
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 = Bool -> Maybe Bool
forall a. a -> Maybe a
Just (Bool -> Maybe Bool)
-> (SClientMethod @t m -> Bool) -> SClientMethod @t m -> Maybe Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SClientMethod @t m -> Bool
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 SClientMethod @t m -> ClientNotOrReq @t m
forall {t :: MessageKind} (m :: Method 'ClientToServer t).
SClientMethod @t m -> ClientNotOrReq @t m
splitClientMethod SClientMethod @t m
m of
    ClientNotOrReq @t m
IsClientNot -> SClientMethod @t m
-> SMethodMap
     @'ClientToServer
     @'Notification
     (ClientMessageHandler m 'Notification)
-> Bool
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 (SMethodMap
   @'ClientToServer
   @'Notification
   (ClientMessageHandler m 'Notification)
 -> Bool)
-> SMethodMap
     @'ClientToServer
     @'Notification
     (ClientMessageHandler m 'Notification)
-> Bool
forall a b. (a -> b) -> a -> b
$ Handlers m
-> SMethodMap
     @'ClientToServer
     @'Notification
     (ClientMessageHandler m 'Notification)
forall (m :: * -> *).
Handlers m
-> SMethodMap
     @'ClientToServer
     @'Notification
     (ClientMessageHandler m 'Notification)
notHandlers Handlers m
h
    ClientNotOrReq @t m
IsClientReq -> SClientMethod @t m
-> SMethodMap
     @'ClientToServer @'Request (ClientMessageHandler m 'Request)
-> Bool
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 (SMethodMap
   @'ClientToServer @'Request (ClientMessageHandler m 'Request)
 -> Bool)
-> SMethodMap
     @'ClientToServer @'Request (ClientMessageHandler m 'Request)
-> Bool
forall a b. (a -> b) -> a -> b
$ Handlers m
-> SMethodMap
     @'ClientToServer @'Request (ClientMessageHandler m 'Request)
forall (m :: * -> *).
Handlers m
-> SMethodMap
     @'ClientToServer @'Request (ClientMessageHandler m 'Request)
reqHandlers Handlers m
h
    ClientNotOrReq @t m
IsClientEither -> String -> Bool
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 =
    SClientMethod @'Request 'Method_TextDocumentCompletion
-> CompletionOptions -> Maybe CompletionOptions
forall {t :: MessageKind} {m :: Method 'ClientToServer t} {a}.
SClientMethod @t m -> a -> Maybe a
supported' SClientMethod @'Request 'Method_TextDocumentCompletion
SMethod_TextDocumentCompletion (CompletionOptions -> Maybe CompletionOptions)
-> CompletionOptions -> Maybe CompletionOptions
forall a b. (a -> b) -> a -> b
$
      CompletionOptions
        { _triggerCharacters :: Maybe [Text]
_triggerCharacters = (Char -> Text) -> String -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Text
T.singleton (String -> [Text]) -> Maybe String -> Maybe [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Options -> Maybe String
optCompletionTriggerCharacters Options
o
        , _allCommitCharacters :: Maybe [Text]
_allCommitCharacters = (Char -> Text) -> String -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Text
T.singleton (String -> [Text]) -> Maybe String -> Maybe [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Options -> Maybe String
optCompletionAllCommitCharacters Options
o
        , _resolveProvider :: Maybe Bool
_resolveProvider = SClientMethod @'Request 'Method_CompletionItemResolve -> Maybe Bool
forall {t :: MessageKind} (m :: Method 'ClientToServer t).
SClientMethod @t m -> Maybe Bool
supported SClientMethod @'Request 'Method_CompletionItemResolve
SMethod_CompletionItemResolve
        , _completionItem :: Maybe ServerCompletionItemOptions
_completionItem = Maybe ServerCompletionItemOptions
forall a. Maybe a
Nothing
        , _workDoneProgress :: Maybe Bool
_workDoneProgress = Maybe Bool
clientInitiatedProgress
        }

  inlayProvider :: Maybe (Bool |? (InlayHintOptions |? InlayHintRegistrationOptions))
inlayProvider =
    SClientMethod @'Request 'Method_TextDocumentInlayHint
-> (Bool |? (InlayHintOptions |? InlayHintRegistrationOptions))
-> Maybe
     (Bool |? (InlayHintOptions |? InlayHintRegistrationOptions))
forall {t :: MessageKind} {m :: Method 'ClientToServer t} {a}.
SClientMethod @t m -> a -> Maybe a
supported' SClientMethod @'Request 'Method_TextDocumentInlayHint
SMethod_TextDocumentInlayHint ((Bool |? (InlayHintOptions |? InlayHintRegistrationOptions))
 -> Maybe
      (Bool |? (InlayHintOptions |? InlayHintRegistrationOptions)))
-> (Bool |? (InlayHintOptions |? InlayHintRegistrationOptions))
-> Maybe
     (Bool |? (InlayHintOptions |? InlayHintRegistrationOptions))
forall a b. (a -> b) -> a -> b
$
      (InlayHintOptions |? InlayHintRegistrationOptions)
-> Bool |? (InlayHintOptions |? InlayHintRegistrationOptions)
forall a b. b -> a |? b
InR ((InlayHintOptions |? InlayHintRegistrationOptions)
 -> Bool |? (InlayHintOptions |? InlayHintRegistrationOptions))
-> (InlayHintOptions |? InlayHintRegistrationOptions)
-> Bool |? (InlayHintOptions |? InlayHintRegistrationOptions)
forall a b. (a -> b) -> a -> b
$
        InlayHintOptions
-> InlayHintOptions |? InlayHintRegistrationOptions
forall a b. a -> a |? b
InL
          InlayHintOptions
            { _workDoneProgress :: Maybe Bool
_workDoneProgress = Maybe Bool
clientInitiatedProgress
            , _resolveProvider :: Maybe Bool
_resolveProvider = SClientMethod @'Request 'Method_InlayHintResolve -> Maybe Bool
forall {t :: MessageKind} (m :: Method 'ClientToServer t).
SClientMethod @t m -> Maybe Bool
supported SClientMethod @'Request 'Method_InlayHintResolve
SMethod_InlayHintResolve
            }

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

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

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

  executeCommandProvider :: Maybe ExecuteCommandOptions
executeCommandProvider =
    SClientMethod @'Request 'Method_WorkspaceExecuteCommand
-> ExecuteCommandOptions -> Maybe ExecuteCommandOptions
forall {t :: MessageKind} {m :: Method 'ClientToServer t} {a}.
SClientMethod @t m -> a -> Maybe a
supported' SClientMethod @'Request 'Method_WorkspaceExecuteCommand
SMethod_WorkspaceExecuteCommand (ExecuteCommandOptions -> Maybe ExecuteCommandOptions)
-> ExecuteCommandOptions -> Maybe ExecuteCommandOptions
forall a b. (a -> b) -> a -> b
$
      case Options -> Maybe [Text]
optExecuteCommandCommands Options
o of
        Just [Text]
cmds -> Maybe Bool -> [Text] -> ExecuteCommandOptions
ExecuteCommandOptions Maybe Bool
clientInitiatedProgress [Text]
cmds
        Maybe [Text]
Nothing -> String -> ExecuteCommandOptions
forall a. HasCallStack => String -> a
error String
"executeCommandCommands needs to be set if a executeCommandHandler is set"

  -- Always provide the default legend
  -- TODO: allow user-provided legend via 'Options', or at least user-provided types
  semanticTokensProvider :: Maybe (SemanticTokensOptions |? SemanticTokensRegistrationOptions)
semanticTokensProvider =
    (SemanticTokensOptions |? SemanticTokensRegistrationOptions)
-> Maybe
     (SemanticTokensOptions |? SemanticTokensRegistrationOptions)
forall a. a -> Maybe a
Just ((SemanticTokensOptions |? SemanticTokensRegistrationOptions)
 -> Maybe
      (SemanticTokensOptions |? SemanticTokensRegistrationOptions))
-> (SemanticTokensOptions |? SemanticTokensRegistrationOptions)
-> Maybe
     (SemanticTokensOptions |? SemanticTokensRegistrationOptions)
forall a b. (a -> b) -> a -> b
$
      SemanticTokensOptions
-> SemanticTokensOptions |? SemanticTokensRegistrationOptions
forall a b. a -> a |? b
InL (SemanticTokensOptions
 -> SemanticTokensOptions |? SemanticTokensRegistrationOptions)
-> SemanticTokensOptions
-> SemanticTokensOptions |? SemanticTokensRegistrationOptions
forall a b. (a -> b) -> a -> b
$
        Maybe Bool
-> SemanticTokensLegend
-> Maybe (Bool |? Rec (Empty @(*)))
-> Maybe (Bool |? SemanticTokensFullDelta)
-> SemanticTokensOptions
SemanticTokensOptions Maybe Bool
clientInitiatedProgress SemanticTokensLegend
defaultSemanticTokensLegend Maybe (Bool |? Rec (Empty @(*)))
forall {b}. Maybe (Bool |? b)
semanticTokenRangeProvider Maybe (Bool |? SemanticTokensFullDelta)
forall {a}. Maybe (a |? SemanticTokensFullDelta)
semanticTokenFullProvider
  semanticTokenRangeProvider :: Maybe (Bool |? b)
semanticTokenRangeProvider
    | SClientMethod @'Request 'Method_TextDocumentSemanticTokensRange
-> Bool
forall {t :: MessageKind} (m :: Method 'ClientToServer t).
SClientMethod @t m -> Bool
supported_b SClientMethod @'Request 'Method_TextDocumentSemanticTokensRange
SMethod_TextDocumentSemanticTokensRange = (Bool |? b) -> Maybe (Bool |? b)
forall a. a -> Maybe a
Just ((Bool |? b) -> Maybe (Bool |? b))
-> (Bool |? b) -> Maybe (Bool |? b)
forall a b. (a -> b) -> a -> b
$ Bool -> Bool |? b
forall a b. a -> a |? b
InL Bool
True
    | Bool
otherwise = Maybe (Bool |? b)
forall a. Maybe a
Nothing
  semanticTokenFullProvider :: Maybe (a |? SemanticTokensFullDelta)
semanticTokenFullProvider
    | SClientMethod @'Request 'Method_TextDocumentSemanticTokensFull
-> Bool
forall {t :: MessageKind} (m :: Method 'ClientToServer t).
SClientMethod @t m -> Bool
supported_b SClientMethod @'Request 'Method_TextDocumentSemanticTokensFull
SMethod_TextDocumentSemanticTokensFull = (a |? SemanticTokensFullDelta)
-> Maybe (a |? SemanticTokensFullDelta)
forall a. a -> Maybe a
Just ((a |? SemanticTokensFullDelta)
 -> Maybe (a |? SemanticTokensFullDelta))
-> (a |? SemanticTokensFullDelta)
-> Maybe (a |? SemanticTokensFullDelta)
forall a b. (a -> b) -> a -> b
$ SemanticTokensFullDelta -> a |? SemanticTokensFullDelta
forall a b. b -> a |? b
InR (SemanticTokensFullDelta -> a |? SemanticTokensFullDelta)
-> SemanticTokensFullDelta -> a |? SemanticTokensFullDelta
forall a b. (a -> b) -> a -> b
$ SemanticTokensFullDelta{_delta :: Maybe Bool
_delta = SClientMethod @'Request 'Method_TextDocumentSemanticTokensFullDelta
-> Maybe Bool
forall {t :: MessageKind} (m :: Method 'ClientToServer t).
SClientMethod @t m -> Maybe Bool
supported SClientMethod @'Request 'Method_TextDocumentSemanticTokensFullDelta
SMethod_TextDocumentSemanticTokensFullDelta}
    | Bool
otherwise = Maybe (a |? SemanticTokensFullDelta)
forall a. Maybe a
Nothing

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

  workspace :: WorkspaceOptions
workspace = WorkspaceOptions{_workspaceFolders :: Maybe WorkspaceFoldersServerCapabilities
_workspaceFolders = Maybe WorkspaceFoldersServerCapabilities
workspaceFolder, _fileOperations :: Maybe FileOperationOptions
_fileOperations = Maybe FileOperationOptions
forall a. Maybe a
Nothing}
  workspaceFolder :: Maybe WorkspaceFoldersServerCapabilities
workspaceFolder =
    SClientMethod
  @'Notification 'Method_WorkspaceDidChangeWorkspaceFolders
-> WorkspaceFoldersServerCapabilities
-> Maybe WorkspaceFoldersServerCapabilities
forall {t :: MessageKind} {m :: Method 'ClientToServer t} {a}.
SClientMethod @t m -> a -> Maybe a
supported' SClientMethod
  @'Notification 'Method_WorkspaceDidChangeWorkspaceFolders
SMethod_WorkspaceDidChangeWorkspaceFolders (WorkspaceFoldersServerCapabilities
 -> Maybe WorkspaceFoldersServerCapabilities)
-> WorkspaceFoldersServerCapabilities
-> Maybe WorkspaceFoldersServerCapabilities
forall a b. (a -> b) -> a -> b
$
      -- sign up to receive notifications
      Maybe Bool
-> Maybe (Text |? Bool) -> WorkspaceFoldersServerCapabilities
WorkspaceFoldersServerCapabilities (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True) ((Text |? Bool) -> Maybe (Text |? Bool)
forall a. a -> Maybe a
Just (Bool -> Text |? Bool
forall a b. b -> a |? b
InR Bool
True))

  diagnosticProvider :: Maybe (DiagnosticOptions |? DiagnosticRegistrationOptions)
diagnosticProvider =
    SClientMethod @'Request 'Method_TextDocumentDiagnostic
-> (DiagnosticOptions |? DiagnosticRegistrationOptions)
-> Maybe (DiagnosticOptions |? DiagnosticRegistrationOptions)
forall {t :: MessageKind} {m :: Method 'ClientToServer t} {a}.
SClientMethod @t m -> a -> Maybe a
supported' SClientMethod @'Request 'Method_TextDocumentDiagnostic
SMethod_TextDocumentDiagnostic ((DiagnosticOptions |? DiagnosticRegistrationOptions)
 -> Maybe (DiagnosticOptions |? DiagnosticRegistrationOptions))
-> (DiagnosticOptions |? DiagnosticRegistrationOptions)
-> Maybe (DiagnosticOptions |? DiagnosticRegistrationOptions)
forall a b. (a -> b) -> a -> b
$
      DiagnosticOptions
-> DiagnosticOptions |? DiagnosticRegistrationOptions
forall a b. a -> a |? b
InL (DiagnosticOptions
 -> DiagnosticOptions |? DiagnosticRegistrationOptions)
-> DiagnosticOptions
-> DiagnosticOptions |? DiagnosticRegistrationOptions
forall a b. (a -> b) -> a -> b
$
        DiagnosticOptions
          { _workDoneProgress :: Maybe Bool
_workDoneProgress = Maybe Bool
clientInitiatedProgress
          , _identifier :: Maybe Text
_identifier = Maybe Text
forall a. Maybe a
Nothing
          , -- TODO: this is a conservative but maybe inaccurate, unclear how much it matters
            _interFileDependencies :: Bool
_interFileDependencies = Bool
True
          , _workspaceDiagnostics :: Bool
_workspaceDiagnostics = SClientMethod @'Request 'Method_WorkspaceDiagnostic -> Bool
forall {t :: MessageKind} (m :: Method 'ClientToServer t).
SClientMethod @t m -> Bool
supported_b SClientMethod @'Request 'Method_WorkspaceDiagnostic
SMethod_WorkspaceDiagnostic
          }

{- | Invokes the registered dynamic or static handlers for the given message and
 method, as well as doing some bookkeeping.
-}
handle :: forall m config meth. (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 -> LogAction m (WithSeverity LspProcessingLog)
-> Maybe (TClientMessage @t meth -> m ())
-> SClientMethod @t meth
-> TClientMessage @t meth
-> m ()
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 ((TNotificationMessage
   @'ClientToServer 'Method_WorkspaceDidChangeWorkspaceFolders
 -> LspT config IO ())
-> Maybe
     (TNotificationMessage
        @'ClientToServer 'Method_WorkspaceDidChangeWorkspaceFolders
      -> LspT config IO ())
forall a. a -> Maybe a
Just TMessage
  @'ClientToServer
  @'Notification
  'Method_WorkspaceDidChangeWorkspaceFolders
-> LspT config IO ()
TNotificationMessage
  @'ClientToServer 'Method_WorkspaceDidChangeWorkspaceFolders
-> LspT config IO ()
forall config.
TMessage
  @'ClientToServer
  @'Notification
  'Method_WorkspaceDidChangeWorkspaceFolders
-> LspM config ()
updateWorkspaceFolders) SClientMethod @t meth
m TClientMessage @t meth
msg
    SClientMethod @t meth
SMethod_WorkspaceDidChangeConfiguration -> LogAction m (WithSeverity LspProcessingLog)
-> Maybe (TClientMessage @t meth -> m ())
-> SClientMethod @t meth
-> TClientMessage @t meth
-> m ()
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 ((TClientMessage @t meth -> m ())
-> Maybe (TClientMessage @t meth -> m ())
forall a. a -> Maybe a
Just ((TClientMessage @t meth -> m ())
 -> Maybe (TClientMessage @t meth -> m ()))
-> (TClientMessage @t meth -> m ())
-> Maybe (TClientMessage @t meth -> m ())
forall a b. (a -> b) -> a -> b
$ LogAction m (WithSeverity LspProcessingLog)
-> TMessage
     @'ClientToServer
     @'Notification
     'Method_WorkspaceDidChangeConfiguration
-> m ()
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 -> LogAction m (WithSeverity LspProcessingLog)
-> Maybe (TClientMessage @t meth -> m ())
-> SClientMethod @t meth
-> TClientMessage @t meth
-> m ()
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 ((TClientMessage @t meth -> m ())
-> Maybe (TClientMessage @t meth -> m ())
forall a. a -> Maybe a
Just ((TClientMessage @t meth -> m ())
 -> Maybe (TClientMessage @t meth -> m ()))
-> (TClientMessage @t meth -> m ())
-> Maybe (TClientMessage @t meth -> m ())
forall a b. (a -> b) -> a -> b
$ \TClientMessage @t meth
_ -> LogAction m (WithSeverity LspProcessingLog) -> m ()
forall (m :: * -> *) config.
((m :: (* -> *)) ~ (LspM config :: (* -> *))) =>
LogAction m (WithSeverity LspProcessingLog) -> m ()
initialDynamicRegistrations LogAction m (WithSeverity LspProcessingLog)
logger m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> LogAction m (WithSeverity LspCoreLog) -> m ()
forall (m :: * -> *) config.
((m :: (* -> *)) ~ (LspM config :: (* -> *))) =>
LogAction m (WithSeverity LspCoreLog) -> m ()
requestConfigUpdate ((WithSeverity LspCoreLog -> WithSeverity LspProcessingLog)
-> LogAction m (WithSeverity LspProcessingLog)
-> LogAction m (WithSeverity LspCoreLog)
forall a b (m :: * -> *).
(a -> b) -> LogAction m b -> LogAction m a
cmap ((LspCoreLog -> LspProcessingLog)
-> WithSeverity LspCoreLog -> WithSeverity LspProcessingLog
forall a b. (a -> b) -> WithSeverity a -> WithSeverity b
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_Shutdown -> LogAction m (WithSeverity LspProcessingLog)
-> Maybe (TClientMessage @t meth -> m ())
-> SClientMethod @t meth
-> TClientMessage @t meth
-> m ()
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 ((TClientMessage @t meth -> m ())
-> Maybe (TClientMessage @t meth -> m ())
forall a. a -> Maybe a
Just ((TClientMessage @t meth -> m ())
 -> Maybe (TClientMessage @t meth -> m ()))
-> (TClientMessage @t meth -> m ())
-> Maybe (TClientMessage @t meth -> m ())
forall a b. (a -> b) -> a -> b
$ \TClientMessage @t meth
_ -> m ()
LspT config IO ()
signalShutdown) SClientMethod @t meth
m TClientMessage @t meth
msg
     where
      -- See Note [Shutdown]
      signalShutdown :: LspM config ()
      signalShutdown :: LspT config IO ()
signalShutdown = do
        LogAction m (WithSeverity LspProcessingLog)
LogAction (LspM config) (WithSeverity LspProcessingLog)
logger LogAction (LspM config) (WithSeverity LspProcessingLog)
-> WithSeverity LspProcessingLog -> LspT config IO ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& LspProcessingLog
ShuttingDown LspProcessingLog -> Severity -> WithSeverity LspProcessingLog
forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` Severity
Info
        Barrier ()
b <- LanguageContextState config -> Barrier ()
forall config. LanguageContextState config -> Barrier ()
resShutdown (LanguageContextState config -> Barrier ())
-> (LanguageContextEnv config -> LanguageContextState config)
-> LanguageContextEnv config
-> Barrier ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LanguageContextEnv config -> LanguageContextState config
forall config.
LanguageContextEnv config -> LanguageContextState config
resState (LanguageContextEnv config -> Barrier ())
-> LspT config IO (LanguageContextEnv config)
-> LspT config IO (Barrier ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LspT config IO (LanguageContextEnv config)
forall config (m :: * -> *).
MonadLsp config m =>
m (LanguageContextEnv config)
getLspEnv
        IO () -> LspT config IO ()
forall a. IO a -> LspT config IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> LspT config IO ()) -> IO () -> LspT config IO ()
forall a b. (a -> b) -> a -> b
$ Barrier () -> () -> IO ()
forall a. HasCallStack => Barrier a -> a -> IO ()
signalBarrier Barrier ()
b ()
    SClientMethod @t meth
SMethod_TextDocumentDidOpen -> LogAction m (WithSeverity LspProcessingLog)
-> Maybe (TClientMessage @t meth -> m ())
-> SClientMethod @t meth
-> TClientMessage @t meth
-> m ()
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 ((TClientMessage @t meth -> m ())
-> Maybe (TClientMessage @t meth -> m ())
forall a. a -> Maybe a
Just ((TClientMessage @t meth -> m ())
 -> Maybe (TClientMessage @t meth -> m ()))
-> (TClientMessage @t meth -> m ())
-> Maybe (TClientMessage @t meth -> m ())
forall a b. (a -> b) -> a -> b
$ LogAction m (WithSeverity LspProcessingLog)
-> (LogAction
      (WriterT [WithSeverity VfsLog] (State VFS)) (WithSeverity VfsLog)
    -> TNotificationMessage
         @'ClientToServer 'Method_TextDocumentDidOpen
    -> WriterT [WithSeverity VfsLog] (State VFS) ())
-> TNotificationMessage
     @'ClientToServer 'Method_TextDocumentDidOpen
-> m ()
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
  (WriterT [WithSeverity VfsLog] (State VFS)) (WithSeverity VfsLog)
-> TMessage
     @'ClientToServer @'Notification 'Method_TextDocumentDidOpen
-> WriterT [WithSeverity VfsLog] (State VFS) ()
LogAction
  (WriterT [WithSeverity VfsLog] (State VFS)) (WithSeverity VfsLog)
-> TNotificationMessage
     @'ClientToServer 'Method_TextDocumentDidOpen
-> WriterT [WithSeverity VfsLog] (State VFS) ()
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 -> LogAction m (WithSeverity LspProcessingLog)
-> Maybe (TClientMessage @t meth -> m ())
-> SClientMethod @t meth
-> TClientMessage @t meth
-> m ()
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 ((TClientMessage @t meth -> m ())
-> Maybe (TClientMessage @t meth -> m ())
forall a. a -> Maybe a
Just ((TClientMessage @t meth -> m ())
 -> Maybe (TClientMessage @t meth -> m ()))
-> (TClientMessage @t meth -> m ())
-> Maybe (TClientMessage @t meth -> m ())
forall a b. (a -> b) -> a -> b
$ LogAction m (WithSeverity LspProcessingLog)
-> (LogAction
      (WriterT [WithSeverity VfsLog] (State VFS)) (WithSeverity VfsLog)
    -> TNotificationMessage
         @'ClientToServer 'Method_TextDocumentDidChange
    -> WriterT [WithSeverity VfsLog] (State VFS) ())
-> TNotificationMessage
     @'ClientToServer 'Method_TextDocumentDidChange
-> m ()
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
  (WriterT [WithSeverity VfsLog] (State VFS)) (WithSeverity VfsLog)
-> TMessage
     @'ClientToServer @'Notification 'Method_TextDocumentDidChange
-> WriterT [WithSeverity VfsLog] (State VFS) ()
LogAction
  (WriterT [WithSeverity VfsLog] (State VFS)) (WithSeverity VfsLog)
-> TNotificationMessage
     @'ClientToServer 'Method_TextDocumentDidChange
-> WriterT [WithSeverity VfsLog] (State VFS) ()
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 -> LogAction m (WithSeverity LspProcessingLog)
-> Maybe (TClientMessage @t meth -> m ())
-> SClientMethod @t meth
-> TClientMessage @t meth
-> m ()
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 ((TClientMessage @t meth -> m ())
-> Maybe (TClientMessage @t meth -> m ())
forall a. a -> Maybe a
Just ((TClientMessage @t meth -> m ())
 -> Maybe (TClientMessage @t meth -> m ()))
-> (TClientMessage @t meth -> m ())
-> Maybe (TClientMessage @t meth -> m ())
forall a b. (a -> b) -> a -> b
$ LogAction m (WithSeverity LspProcessingLog)
-> (LogAction
      (WriterT [WithSeverity VfsLog] (State VFS)) (WithSeverity VfsLog)
    -> TNotificationMessage
         @'ClientToServer 'Method_TextDocumentDidClose
    -> WriterT [WithSeverity VfsLog] (State VFS) ())
-> TNotificationMessage
     @'ClientToServer 'Method_TextDocumentDidClose
-> m ()
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
  (WriterT [WithSeverity VfsLog] (State VFS)) (WithSeverity VfsLog)
-> TMessage
     @'ClientToServer @'Notification 'Method_TextDocumentDidClose
-> WriterT [WithSeverity VfsLog] (State VFS) ()
LogAction
  (WriterT [WithSeverity VfsLog] (State VFS)) (WithSeverity VfsLog)
-> TNotificationMessage
     @'ClientToServer 'Method_TextDocumentDidClose
-> WriterT [WithSeverity VfsLog] (State VFS) ()
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 -> LogAction m (WithSeverity LspProcessingLog)
-> Maybe (TClientMessage @t meth -> m ())
-> SClientMethod @t meth
-> TClientMessage @t meth
-> m ()
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 ((TClientMessage @t meth -> m ())
-> Maybe (TClientMessage @t meth -> m ())
forall a. a -> Maybe a
Just ((TClientMessage @t meth -> m ())
 -> Maybe (TClientMessage @t meth -> m ()))
-> (TClientMessage @t meth -> m ())
-> Maybe (TClientMessage @t meth -> m ())
forall a b. (a -> b) -> a -> b
$ LogAction m (WithSeverity LspProcessingLog)
-> TMessage
     @'ClientToServer
     @'Notification
     'Method_WindowWorkDoneProgressCancel
-> m ()
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
_ -> LogAction m (WithSeverity LspProcessingLog)
-> Maybe (TClientMessage @t meth -> m ())
-> SClientMethod @t meth
-> TClientMessage @t meth
-> m ()
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 ())
Maybe (TClientMessage @t meth -> LspT config IO ())
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) ->
  -- | An action to be run before invoking the handler, used for
  -- bookkeeping stuff like the vfs etc.
  Maybe (TClientMessage meth -> m ()) ->
  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
  Bool
shutdown <- m Bool
forall (m :: * -> *) config.
((m :: (* -> *)) ~ (LspM config :: (* -> *))) =>
m Bool
isShuttingDown
  -- These are the methods that we are allowed to process during shutdown.
  -- The reason that we do not include 'shutdown' itself here is because
  -- by the time we get the first 'shutdown' message, isShuttingDown will
  -- still be false, so we would still be able to process it.
  -- This ensures we won't process the second 'shutdown' message and only
  -- process 'exit' during shutdown.
  let allowedMethod :: SClientMethod @t m -> Bool
allowedMethod SClientMethod @t m
m = case (SClientMethod @t m -> ClientNotOrReq @t m
forall {t :: MessageKind} (m :: Method 'ClientToServer t).
SClientMethod @t m -> ClientNotOrReq @t m
splitClientMethod SClientMethod @t m
m, SClientMethod @t m
m) of
        (ClientNotOrReq @t m
IsClientNot, SClientMethod @t m
SMethod_Exit) -> Bool
True
        (ClientNotOrReq @t m, SClientMethod @t m)
_ -> Bool
False

  case Maybe (TClientMessage @t meth -> m ())
mAction of
    Just TClientMessage @t meth -> m ()
f | Bool -> Bool
not Bool
shutdown Bool -> Bool -> Bool
|| SClientMethod @t meth -> Bool
forall {t :: MessageKind} (m :: Method 'ClientToServer t).
SClientMethod @t m -> Bool
allowedMethod SClientMethod @t meth
m -> TClientMessage @t meth -> m ()
f TClientMessage @t meth
msg
    Maybe (TClientMessage @t meth -> m ())
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

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

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

  case SClientMethod @t meth -> ClientNotOrReq @t meth
forall {t :: MessageKind} (m :: Method 'ClientToServer t).
SClientMethod @t m -> ClientNotOrReq @t m
splitClientMethod SClientMethod @t meth
m of
    -- See Note [Shutdown]
    ClientNotOrReq @t meth
IsClientNot | Bool
shutdown, Bool -> Bool
not (SClientMethod @t meth -> Bool
forall {t :: MessageKind} (m :: Method 'ClientToServer t).
SClientMethod @t m -> Bool
allowedMethod SClientMethod @t meth
m) -> m ()
notificationDuringShutdown
    ClientNotOrReq @t meth
IsClientNot -> case RegistrationMap t
-> SMethodMap @'ClientToServer @t (ClientMessageHandler IO t)
-> Maybe (Handler @'ClientToServer @t IO meth)
pickHandler RegistrationMap t
RegistrationMap 'Notification
dynNotHandlers SMethodMap @'ClientToServer @t (ClientMessageHandler IO t)
SMethodMap
  @'ClientToServer
  @'Notification
  (ClientMessageHandler IO 'Notification)
notHandlers of
      Just Handler @'ClientToServer @t IO meth
h -> IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Handler @'ClientToServer @t IO meth
TNotificationMessage @'ClientToServer meth -> IO ()
h TClientMessage @t meth
TNotificationMessage @'ClientToServer meth
msg
      Maybe (Handler @'ClientToServer @t IO meth)
Nothing
        | SClientMethod @t meth
SMethod_Exit <- SClientMethod @t meth
m -> LogAction m (WithSeverity LspProcessingLog)
-> Handler @'ClientToServer @'Notification m 'Method_Exit
forall (m :: * -> *).
MonadIO m =>
LogAction m (WithSeverity LspProcessingLog)
-> Handler @'ClientToServer @'Notification m 'Method_Exit
exitNotificationHandler LogAction m (WithSeverity LspProcessingLog)
logger TClientMessage @t meth
TNotificationMessage @'ClientToServer 'Method_Exit
msg
        | Bool
otherwise -> m ()
missingNotificationHandler
    -- See Note [Shutdown]
    ClientNotOrReq @t meth
IsClientReq | Bool
shutdown, Bool -> Bool
not (SClientMethod @t meth -> Bool
forall {t :: MessageKind} (m :: Method 'ClientToServer t).
SClientMethod @t m -> Bool
allowedMethod SClientMethod @t meth
m) -> TRequestMessage @'ClientToServer meth -> m ()
forall (m1 :: Method 'ClientToServer 'Request).
TRequestMessage @'ClientToServer m1 -> m ()
requestDuringShutdown TClientMessage @t meth
TRequestMessage @'ClientToServer meth
msg
    ClientNotOrReq @t meth
IsClientReq -> case RegistrationMap t
-> SMethodMap @'ClientToServer @t (ClientMessageHandler IO t)
-> Maybe (Handler @'ClientToServer @t IO meth)
pickHandler RegistrationMap t
RegistrationMap 'Request
dynReqHandlers SMethodMap @'ClientToServer @t (ClientMessageHandler IO t)
SMethodMap
  @'ClientToServer @'Request (ClientMessageHandler IO 'Request)
reqHandlers of
      Just Handler @'ClientToServer @t IO meth
h -> IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Handler @'ClientToServer @t IO meth
TRequestMessage @'ClientToServer meth
-> (Either
      (TResponseError @'ClientToServer meth)
      (MessageResult @'ClientToServer @'Request meth)
    -> IO ())
-> IO ()
h TClientMessage @t meth
TRequestMessage @'ClientToServer meth
msg (LanguageContextEnv config -> LspT config IO () -> IO ()
forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
runLspT LanguageContextEnv config
env (LspT config IO () -> IO ())
-> (Either
      (TResponseError @'ClientToServer meth)
      (MessageResult @'ClientToServer @'Request meth)
    -> LspT config IO ())
-> Either
     (TResponseError @'ClientToServer meth)
     (MessageResult @'ClientToServer @'Request meth)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TRequestMessage @'ClientToServer meth
-> Either
     (TResponseError @'ClientToServer meth)
     (MessageResult @'ClientToServer @'Request meth)
-> m ()
forall (m1 :: Method 'ClientToServer 'Request).
TRequestMessage @'ClientToServer m1
-> Either
     (TResponseError @'ClientToServer m1)
     (MessageResult @'ClientToServer @'Request m1)
-> m ()
sendResponse TClientMessage @t meth
TRequestMessage @'ClientToServer meth
msg)
      Maybe (Handler @'ClientToServer @t IO meth)
Nothing
        | SClientMethod @t meth
SMethod_Shutdown <- SClientMethod @t meth
m -> IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Handler @'ClientToServer @'Request IO 'Method_Shutdown
TRequestMessage @'ClientToServer 'Method_Shutdown
-> (Either (TResponseError @'ClientToServer 'Method_Shutdown) Null
    -> IO ())
-> IO ()
shutdownRequestHandler TClientMessage @t meth
TRequestMessage @'ClientToServer 'Method_Shutdown
msg (LanguageContextEnv config -> LspT config IO () -> IO ()
forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
runLspT LanguageContextEnv config
env (LspT config IO () -> IO ())
-> (Either (TResponseError @'ClientToServer 'Method_Shutdown) Null
    -> LspT config IO ())
-> Either (TResponseError @'ClientToServer 'Method_Shutdown) Null
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TRequestMessage @'ClientToServer 'Method_Shutdown
-> Either
     (TResponseError @'ClientToServer 'Method_Shutdown)
     (MessageResult @'ClientToServer @'Request 'Method_Shutdown)
-> m ()
forall (m1 :: Method 'ClientToServer 'Request).
TRequestMessage @'ClientToServer m1
-> Either
     (TResponseError @'ClientToServer m1)
     (MessageResult @'ClientToServer @'Request m1)
-> m ()
sendResponse TClientMessage @t meth
TRequestMessage @'ClientToServer 'Method_Shutdown
msg)
        | Bool
otherwise -> TRequestMessage @'ClientToServer meth -> m ()
forall (m1 :: Method 'ClientToServer 'Request).
TRequestMessage @'ClientToServer m1 -> m ()
missingRequestHandler TClientMessage @t meth
TRequestMessage @'ClientToServer meth
msg
    ClientNotOrReq @t meth
IsClientEither -> case TClientMessage @t meth
msg of
      -- See Note [Shutdown]
      NotMess TNotificationMessage
  @'ClientToServer
  ('Method_CustomMethod @'ClientToServer @'Notification s)
_ | Bool
shutdown -> m ()
notificationDuringShutdown
      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 t
RegistrationMap 'Notification
dynNotHandlers SMethodMap @'ClientToServer @t (ClientMessageHandler IO t)
SMethodMap
  @'ClientToServer
  @'Notification
  (ClientMessageHandler IO 'Notification)
notHandlers of
        Just Handler @'ClientToServer @t IO meth
h -> IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Handler @'ClientToServer @t IO meth
TNotificationMessage
  @'ClientToServer
  ('Method_CustomMethod @'ClientToServer @'Notification s)
-> IO ()
h TNotificationMessage
  @'ClientToServer
  ('Method_CustomMethod @'ClientToServer @'Notification s)
noti
        Maybe (Handler @'ClientToServer @t IO meth)
Nothing -> m ()
missingNotificationHandler
      -- See Note [Shutdown]
      ReqMess TRequestMessage
  @'ClientToServer
  ('Method_CustomMethod @'ClientToServer @'Request s)
req | Bool
shutdown -> TRequestMessage
  @'ClientToServer
  ('Method_CustomMethod @'ClientToServer @'Request s)
-> m ()
forall (m1 :: Method 'ClientToServer 'Request).
TRequestMessage @'ClientToServer m1 -> m ()
requestDuringShutdown TRequestMessage
  @'ClientToServer
  ('Method_CustomMethod @'ClientToServer @'Request s)
req
      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 t
RegistrationMap 'Request
dynReqHandlers SMethodMap @'ClientToServer @t (ClientMessageHandler IO t)
SMethodMap
  @'ClientToServer @'Request (ClientMessageHandler IO 'Request)
reqHandlers of
        Just Handler @'ClientToServer @t IO meth
h -> IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Handler @'ClientToServer @t IO meth
TRequestMessage
  @'ClientToServer
  ('Method_CustomMethod @'ClientToServer @'Request s)
-> (Either
      (TResponseError
         @'ClientToServer
         ('Method_CustomMethod @'ClientToServer @'Request s))
      Value
    -> IO ())
-> IO ()
h TRequestMessage
  @'ClientToServer
  ('Method_CustomMethod @'ClientToServer @'Request s)
req (LanguageContextEnv config -> LspT config IO () -> IO ()
forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
runLspT LanguageContextEnv config
env (LspT config IO () -> IO ())
-> (Either
      (TResponseError
         @'ClientToServer
         ('Method_CustomMethod @'ClientToServer @'Request s))
      Value
    -> LspT config IO ())
-> Either
     (TResponseError
        @'ClientToServer
        ('Method_CustomMethod @'ClientToServer @'Request s))
     Value
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TRequestMessage
  @'ClientToServer
  ('Method_CustomMethod @'ClientToServer @'Request s)
-> Either
     (TResponseError
        @'ClientToServer
        ('Method_CustomMethod @'ClientToServer @'Request s))
     (MessageResult
        @'ClientToServer
        @'Request
        ('Method_CustomMethod @'ClientToServer @'Request s))
-> m ()
forall (m1 :: Method 'ClientToServer 'Request).
TRequestMessage @'ClientToServer m1
-> Either
     (TResponseError @'ClientToServer m1)
     (MessageResult @'ClientToServer @'Request m1)
-> m ()
sendResponse TRequestMessage
  @'ClientToServer
  ('Method_CustomMethod @'ClientToServer @'Request s)
req)
        Maybe (Handler @'ClientToServer @t IO meth)
Nothing -> TRequestMessage
  @'ClientToServer
  ('Method_CustomMethod @'ClientToServer @'Request s)
-> m ()
forall (m1 :: Method 'ClientToServer 'Request).
TRequestMessage @'ClientToServer m1 -> m ()
missingRequestHandler TRequestMessage
  @'ClientToServer
  ('Method_CustomMethod @'ClientToServer @'Request s)
req
 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 (SClientMethod @t meth
-> RegistrationMap t
-> Maybe
     (Product
        @(Method 'ClientToServer t)
        (RegistrationId @t)
        (ClientMessageHandler IO t)
        meth)
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, SClientMethod @t meth
-> SMethodMap @'ClientToServer @t (ClientMessageHandler IO t)
-> Maybe (ClientMessageHandler IO t meth)
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)
_) -> Handler @'ClientToServer @t IO meth
-> Maybe (Handler @'ClientToServer @t IO 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)) -> Handler @'ClientToServer @t IO meth
-> Maybe (Handler @'ClientToServer @t IO 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, Maybe (ClientMessageHandler IO t meth)
Nothing) -> Maybe (Handler @'ClientToServer @t IO meth)
forall a. Maybe a
Nothing

  sendResponse :: forall m1. TRequestMessage (m1 :: Method ClientToServer Request) -> Either (TResponseError m1) (MessageResult m1) -> m ()
  sendResponse :: forall (m1 :: Method 'ClientToServer 'Request).
TRequestMessage @'ClientToServer m1
-> Either
     (TResponseError @'ClientToServer m1)
     (MessageResult @'ClientToServer @'Request m1)
-> m ()
sendResponse TRequestMessage @'ClientToServer m1
req Either
  (TResponseError @'ClientToServer m1)
  (MessageResult @'ClientToServer @'Request m1)
res = FromServerMessage -> m ()
forall config (m :: * -> *).
MonadLsp config m =>
FromServerMessage -> m ()
sendToClient (FromServerMessage -> m ()) -> FromServerMessage -> m ()
forall a b. (a -> b) -> a -> b
$ SMethod @'ClientToServer @'Request m1
-> TResponseMessage @'ClientToServer m1 -> FromServerMessage
forall (m :: Method 'ClientToServer 'Request)
       (a :: Method 'ClientToServer 'Request -> *).
a m -> TResponseMessage @'ClientToServer m -> FromServerMessage' a
FromServerRsp (TRequestMessage @'ClientToServer m1
req TRequestMessage @'ClientToServer m1
-> Getting
     (SMethod @'ClientToServer @'Request m1)
     (TRequestMessage @'ClientToServer m1)
     (SMethod @'ClientToServer @'Request m1)
-> SMethod @'ClientToServer @'Request m1
forall s a. s -> Getting a s a -> a
^. Getting
  (SMethod @'ClientToServer @'Request m1)
  (TRequestMessage @'ClientToServer m1)
  (SMethod @'ClientToServer @'Request m1)
forall s a. HasMethod s a => Lens' s a
Lens'
  (TRequestMessage @'ClientToServer m1)
  (SMethod @'ClientToServer @'Request m1)
L.method) (TResponseMessage @'ClientToServer m1 -> FromServerMessage)
-> TResponseMessage @'ClientToServer m1 -> FromServerMessage
forall a b. (a -> b) -> a -> b
$ Text
-> Maybe (LspId @'ClientToServer m1)
-> Either
     (TResponseError @'ClientToServer m1)
     (MessageResult @'ClientToServer @'Request m1)
-> TResponseMessage @'ClientToServer m1
forall (f :: MessageDirection) (m :: Method f 'Request).
Text
-> Maybe (LspId @f m)
-> Either (TResponseError @f m) (MessageResult @f @'Request m)
-> TResponseMessage @f m
TResponseMessage Text
"2.0" (LspId @'ClientToServer m1 -> Maybe (LspId @'ClientToServer m1)
forall a. a -> Maybe a
Just (TRequestMessage @'ClientToServer m1
req TRequestMessage @'ClientToServer m1
-> Getting
     (LspId @'ClientToServer m1)
     (TRequestMessage @'ClientToServer m1)
     (LspId @'ClientToServer m1)
-> LspId @'ClientToServer m1
forall s a. s -> Getting a s a -> a
^. Getting
  (LspId @'ClientToServer m1)
  (TRequestMessage @'ClientToServer m1)
  (LspId @'ClientToServer m1)
forall s a. HasId s a => Lens' s a
Lens'
  (TRequestMessage @'ClientToServer m1) (LspId @'ClientToServer m1)
L.id)) Either
  (TResponseError @'ClientToServer m1)
  (MessageResult @'ClientToServer @'Request m1)
res

  requestDuringShutdown :: forall m1. TRequestMessage (m1 :: Method ClientToServer Request) -> m ()
  requestDuringShutdown :: forall (m1 :: Method 'ClientToServer 'Request).
TRequestMessage @'ClientToServer m1 -> m ()
requestDuringShutdown TRequestMessage @'ClientToServer m1
req = do
    LogAction m (WithSeverity LspProcessingLog)
logger LogAction m (WithSeverity LspProcessingLog)
-> WithSeverity LspProcessingLog -> m ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& SClientMethod @t meth -> LspProcessingLog
forall {t :: MessageKind} (m :: Method 'ClientToServer t).
SClientMethod @t m -> LspProcessingLog
MessageDuringShutdown SClientMethod @t meth
m LspProcessingLog -> Severity -> WithSeverity LspProcessingLog
forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` Severity
Warning
    TRequestMessage @'ClientToServer m1
-> Either
     (TResponseError @'ClientToServer m1)
     (MessageResult @'ClientToServer @'Request m1)
-> m ()
forall (m1 :: Method 'ClientToServer 'Request).
TRequestMessage @'ClientToServer m1
-> Either
     (TResponseError @'ClientToServer m1)
     (MessageResult @'ClientToServer @'Request m1)
-> m ()
sendResponse TRequestMessage @'ClientToServer m1
req (TResponseError @'ClientToServer m1
-> Either
     (TResponseError @'ClientToServer m1)
     (MessageResult @'ClientToServer @'Request m1)
forall a b. a -> Either a b
Left ((LSPErrorCodes |? ErrorCodes)
-> Text
-> Maybe (ErrorData @'ClientToServer @'Request m1)
-> TResponseError @'ClientToServer m1
forall (f :: MessageDirection) (m :: Method f 'Request).
(LSPErrorCodes |? ErrorCodes)
-> Text -> Maybe (ErrorData @f @'Request m) -> TResponseError @f m
TResponseError (ErrorCodes -> LSPErrorCodes |? ErrorCodes
forall a b. b -> a |? b
InR ErrorCodes
ErrorCodes_InvalidRequest) Text
"Server is shutdown" Maybe (ErrorData @'ClientToServer @'Request m1)
forall a. Maybe a
Nothing))

  notificationDuringShutdown :: m ()
  notificationDuringShutdown :: m ()
notificationDuringShutdown = LogAction m (WithSeverity LspProcessingLog)
logger LogAction m (WithSeverity LspProcessingLog)
-> WithSeverity LspProcessingLog -> m ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& SClientMethod @t meth -> LspProcessingLog
forall {t :: MessageKind} (m :: Method 'ClientToServer t).
SClientMethod @t m -> LspProcessingLog
MessageDuringShutdown SClientMethod @t meth
m LspProcessingLog -> Severity -> WithSeverity LspProcessingLog
forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` Severity
Warning

  -- '$/' 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.
  missingNotificationHandler :: m ()
  missingNotificationHandler :: m ()
missingNotificationHandler =
    let optional :: Bool
optional = SomeMethod -> Bool
isOptionalMethod (SClientMethod @t meth -> SomeMethod
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 LogAction m (WithSeverity LspProcessingLog)
-> WithSeverity LspProcessingLog -> m ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& Bool -> SClientMethod @t meth -> LspProcessingLog
forall {t :: MessageKind} (m :: Method 'ClientToServer t).
Bool -> SClientMethod @t m -> LspProcessingLog
MissingHandler Bool
optional SClientMethod @t meth
m LspProcessingLog -> Severity -> WithSeverity LspProcessingLog
forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` if Bool
optional then Severity
Warning else Severity
Error

  missingRequestHandler :: TRequestMessage (m1 :: Method ClientToServer Request) -> m ()
  missingRequestHandler :: forall (m1 :: Method 'ClientToServer 'Request).
TRequestMessage @'ClientToServer m1 -> m ()
missingRequestHandler TRequestMessage @'ClientToServer m1
req = do
    LogAction m (WithSeverity LspProcessingLog)
logger LogAction m (WithSeverity LspProcessingLog)
-> WithSeverity LspProcessingLog -> m ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& Bool -> SClientMethod @t meth -> LspProcessingLog
forall {t :: MessageKind} (m :: Method 'ClientToServer t).
Bool -> SClientMethod @t m -> LspProcessingLog
MissingHandler Bool
False SClientMethod @t meth
m LspProcessingLog -> Severity -> WithSeverity LspProcessingLog
forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` Severity
Error
    let errorMsg :: Text
errorMsg = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String
"No handler for: ", SClientMethod @t meth -> String
forall a. Show a => a -> String
show SClientMethod @t meth
m]
        err :: TResponseError @'ClientToServer m1
err = (LSPErrorCodes |? ErrorCodes)
-> Text
-> Maybe (ErrorData @'ClientToServer @'Request m1)
-> TResponseError @'ClientToServer m1
forall (f :: MessageDirection) (m :: Method f 'Request).
(LSPErrorCodes |? ErrorCodes)
-> Text -> Maybe (ErrorData @f @'Request m) -> TResponseError @f m
TResponseError (ErrorCodes -> LSPErrorCodes |? ErrorCodes
forall a b. b -> a |? b
InR ErrorCodes
ErrorCodes_MethodNotFound) Text
errorMsg Maybe (ErrorData @'ClientToServer @'Request m1)
forall a. Maybe a
Nothing
    TRequestMessage @'ClientToServer m1
-> Either
     (TResponseError @'ClientToServer m1)
     (MessageResult @'ClientToServer @'Request m1)
-> m ()
forall (m1 :: Method 'ClientToServer 'Request).
TRequestMessage @'ClientToServer m1
-> Either
     (TResponseError @'ClientToServer m1)
     (MessageResult @'ClientToServer @'Request m1)
-> m ()
sendResponse TRequestMessage @'ClientToServer m1
req (TResponseError @'ClientToServer m1
-> Either
     (TResponseError @'ClientToServer m1)
     (MessageResult @'ClientToServer @'Request m1)
forall a b. a -> Either a b
Left TResponseError @'ClientToServer m1
err)

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 <- (LanguageContextState config -> TVar (Map ProgressToken (IO ())))
-> m (Map ProgressToken (IO ()))
forall config (m :: * -> *) a.
MonadLsp config m =>
(LanguageContextState config -> TVar a) -> m a
getsState (ProgressData -> TVar (Map ProgressToken (IO ()))
progressCancel (ProgressData -> TVar (Map ProgressToken (IO ())))
-> (LanguageContextState config -> ProgressData)
-> LanguageContextState config
-> TVar (Map ProgressToken (IO ()))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LanguageContextState config -> ProgressData
forall config. LanguageContextState config -> ProgressData
resProgressData)
  case ProgressToken -> Map ProgressToken (IO ()) -> Maybe (IO ())
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ProgressToken
tid Map ProgressToken (IO ())
pdata of
    Maybe (IO ())
Nothing -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just IO ()
cancelAction -> do
      LogAction m (WithSeverity LspProcessingLog)
logger LogAction m (WithSeverity LspProcessingLog)
-> WithSeverity LspProcessingLog -> m ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& ProgressToken -> LspProcessingLog
ProgressCancel ProgressToken
tid LspProcessingLog -> Severity -> WithSeverity LspProcessingLog
forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` Severity
Debug
      IO () -> m ()
forall a. IO a -> m a
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 LogAction m (WithSeverity LspProcessingLog)
-> WithSeverity LspProcessingLog -> m ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& LspProcessingLog
Exiting LspProcessingLog -> Severity -> WithSeverity LspProcessingLog
forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` Severity
Info
  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
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 (TResponseError @'ClientToServer 'Method_Shutdown) Null
-> IO ()
k = do
  Either (TResponseError @'ClientToServer 'Method_Shutdown) Null
-> IO ()
k (Either (TResponseError @'ClientToServer 'Method_Shutdown) Null
 -> IO ())
-> Either (TResponseError @'ClientToServer 'Method_Shutdown) Null
-> IO ()
forall a b. (a -> b) -> a -> b
$ Null
-> Either (TResponseError @'ClientToServer 'Method_Shutdown) Null
forall a b. b -> Either a b
Right Null
Null

initialDynamicRegistrations :: (m ~ LspM config) => LogAction m (WithSeverity LspProcessingLog) -> m ()
initialDynamicRegistrations :: forall (m :: * -> *) config.
((m :: (* -> *)) ~ (LspM config :: (* -> *))) =>
LogAction m (WithSeverity LspProcessingLog) -> m ()
initialDynamicRegistrations LogAction m (WithSeverity LspProcessingLog)
logger = do
  Text
section <- ReaderT (LanguageContextEnv config) IO Text -> LspT config IO Text
forall config (m :: * -> *) a.
ReaderT (LanguageContextEnv config) m a -> LspT config m a
LspT (ReaderT (LanguageContextEnv config) IO Text
 -> LspT config IO Text)
-> ReaderT (LanguageContextEnv config) IO Text
-> LspT config IO Text
forall a b. (a -> b) -> a -> b
$ (LanguageContextEnv config -> Text)
-> ReaderT (LanguageContextEnv config) IO Text
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks LanguageContextEnv config -> Text
forall config. LanguageContextEnv config -> Text
resConfigSection
  -- We need to register for `workspace/didChangeConfiguration` dynamically in order to
  -- ensure we receive notifications. See
  -- https://microsoft.github.io/language-server-protocol/specifications/lsp/3.17/specification/#workspace_configuration
  -- https://github.com/microsoft/language-server-protocol/issues/1888
  m (Maybe
     (RegistrationToken
        @'Notification 'Method_WorkspaceDidChangeConfiguration))
-> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Maybe
      (RegistrationToken
         @'Notification 'Method_WorkspaceDidChangeConfiguration))
 -> m ())
-> m (Maybe
        (RegistrationToken
           @'Notification 'Method_WorkspaceDidChangeConfiguration))
-> m ()
forall a b. (a -> b) -> a -> b
$
    LogAction m (WithSeverity LspCoreLog)
-> SClientMethod
     @'Notification 'Method_WorkspaceDidChangeConfiguration
-> RegistrationOptions
     @'ClientToServer
     @'Notification
     'Method_WorkspaceDidChangeConfiguration
-> m (Maybe
        (RegistrationToken
           @'Notification 'Method_WorkspaceDidChangeConfiguration))
forall (f :: * -> *) (t :: MessageKind)
       (m :: Method 'ClientToServer t) config.
MonadLsp config f =>
LogAction f (WithSeverity LspCoreLog)
-> SClientMethod @t m
-> RegistrationOptions @'ClientToServer @t m
-> f (Maybe (RegistrationToken @t m))
trySendRegistration
      ((WithSeverity LspCoreLog -> WithSeverity LspProcessingLog)
-> LogAction m (WithSeverity LspProcessingLog)
-> LogAction m (WithSeverity LspCoreLog)
forall a b (m :: * -> *).
(a -> b) -> LogAction m b -> LogAction m a
cmap ((LspCoreLog -> LspProcessingLog)
-> WithSeverity LspCoreLog -> WithSeverity LspProcessingLog
forall a b. (a -> b) -> WithSeverity a -> WithSeverity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LspCoreLog -> LspProcessingLog
LspCore) LogAction m (WithSeverity LspProcessingLog)
logger)
      SClientMethod
  @'Notification 'Method_WorkspaceDidChangeConfiguration
SMethod_WorkspaceDidChangeConfiguration
      (Maybe (Text |? [Text]) -> DidChangeConfigurationRegistrationOptions
DidChangeConfigurationRegistrationOptions ((Text |? [Text]) -> Maybe (Text |? [Text])
forall a. a -> Maybe a
Just ((Text |? [Text]) -> Maybe (Text |? [Text]))
-> (Text |? [Text]) -> Maybe (Text |? [Text])
forall a b. (a -> b) -> a -> b
$ Text -> Text |? [Text]
forall a b. a -> a |? b
InL Text
section))

{- | 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 Object -> Getting (Maybe Value) Object (Maybe Value) -> Maybe Value
forall s a. s -> Getting a s a -> a
^. Index Object -> Lens' Object (Maybe (IxValue Object))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at (String -> Index Object
forall a. IsString a => String -> a
fromString (String -> Index Object) -> String -> Index Object
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 <- ReaderT (LanguageContextEnv config) IO Text -> LspT config IO Text
forall config (m :: * -> *) a.
ReaderT (LanguageContextEnv config) m a -> LspT config m a
LspT (ReaderT (LanguageContextEnv config) IO Text
 -> LspT config IO Text)
-> ReaderT (LanguageContextEnv config) IO Text
-> LspT config IO Text
forall a b. (a -> b) -> a -> b
$ (LanguageContextEnv config -> Text)
-> ReaderT (LanguageContextEnv config) IO Text
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks LanguageContextEnv config -> Text
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.
  LogAction m (WithSeverity LspCoreLog) -> Value -> m ()
forall (m :: * -> *) config.
((m :: (* -> *)) ~ (LspM config :: (* -> *))) =>
LogAction m (WithSeverity LspCoreLog) -> Value -> m ()
tryChangeConfig ((WithSeverity LspCoreLog -> WithSeverity LspProcessingLog)
-> LogAction m (WithSeverity LspProcessingLog)
-> LogAction m (WithSeverity LspCoreLog)
forall a b (m :: * -> *).
(a -> b) -> LogAction m b -> LogAction m a
cmap ((LspCoreLog -> LspProcessingLog)
-> WithSeverity LspCoreLog -> WithSeverity LspProcessingLog
forall a b. (a -> b) -> WithSeverity a -> WithSeverity b
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 (Value -> Value) -> Value -> Value
forall a b. (a -> b) -> a -> b
$ TMessage
  @'ClientToServer
  @'Notification
  'Method_WorkspaceDidChangeConfiguration
TNotificationMessage
  @'ClientToServer 'Method_WorkspaceDidChangeConfiguration
req TNotificationMessage
  @'ClientToServer 'Method_WorkspaceDidChangeConfiguration
-> Getting
     Value
     (TNotificationMessage
        @'ClientToServer 'Method_WorkspaceDidChangeConfiguration)
     Value
-> Value
forall s a. s -> Getting a s a -> a
^. (DidChangeConfigurationParams
 -> Const @(*) Value DidChangeConfigurationParams)
-> TNotificationMessage
     @'ClientToServer 'Method_WorkspaceDidChangeConfiguration
-> Const
     @(*)
     Value
     (TNotificationMessage
        @'ClientToServer 'Method_WorkspaceDidChangeConfiguration)
forall s a. HasParams s a => Lens' s a
Lens'
  (TNotificationMessage
     @'ClientToServer 'Method_WorkspaceDidChangeConfiguration)
  DidChangeConfigurationParams
L.params ((DidChangeConfigurationParams
  -> Const @(*) Value DidChangeConfigurationParams)
 -> TNotificationMessage
      @'ClientToServer 'Method_WorkspaceDidChangeConfiguration
 -> Const
      @(*)
      Value
      (TNotificationMessage
         @'ClientToServer 'Method_WorkspaceDidChangeConfiguration))
-> ((Value -> Const @(*) Value Value)
    -> DidChangeConfigurationParams
    -> Const @(*) Value DidChangeConfigurationParams)
-> Getting
     Value
     (TNotificationMessage
        @'ClientToServer 'Method_WorkspaceDidChangeConfiguration)
     Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> Const @(*) Value Value)
-> DidChangeConfigurationParams
-> Const @(*) Value DidChangeConfigurationParams
forall s a. HasSettings s a => Lens' s a
Lens' DidChangeConfigurationParams Value
L.settings)
  LogAction m (WithSeverity LspCoreLog) -> m ()
forall (m :: * -> *) config.
((m :: (* -> *)) ~ (LspM config :: (* -> *))) =>
LogAction m (WithSeverity LspCoreLog) -> m ()
requestConfigUpdate ((WithSeverity LspCoreLog -> WithSeverity LspProcessingLog)
-> LogAction m (WithSeverity LspProcessingLog)
-> LogAction m (WithSeverity LspCoreLog)
forall a b (m :: * -> *).
(a -> b) -> LogAction m b -> LogAction m a
cmap ((LspCoreLog -> LspProcessingLog)
-> WithSeverity LspCoreLog -> WithSeverity LspProcessingLog
forall a b. (a -> b) -> WithSeverity a -> WithSeverity b
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 <- (LanguageContextState config -> TVar VFSData)
-> (VFSData -> ([WithSeverity VfsLog], VFSData))
-> m [WithSeverity VfsLog]
forall config (m :: * -> *) s a.
MonadLsp config m =>
(LanguageContextState config -> TVar s) -> (s -> (a, s)) -> m a
stateState LanguageContextState config -> TVar VFSData
forall config. LanguageContextState config -> TVar VFSData
resVFS ((VFSData -> ([WithSeverity VfsLog], VFSData))
 -> m [WithSeverity VfsLog])
-> (VFSData -> ([WithSeverity VfsLog], VFSData))
-> m [WithSeverity VfsLog]
forall a b. (a -> b) -> a -> b
$ \(VFSData VFS
vfs Map String String
rm) ->
    let ([WithSeverity VfsLog]
ls, VFS
vfs') = (State VFS [WithSeverity VfsLog]
 -> VFS -> ([WithSeverity VfsLog], VFS))
-> VFS
-> State VFS [WithSeverity VfsLog]
-> ([WithSeverity VfsLog], VFS)
forall a b c. (a -> b -> c) -> b -> a -> c
flip State VFS [WithSeverity VfsLog]
-> VFS -> ([WithSeverity VfsLog], VFS)
forall s a. State s a -> s -> (a, s)
runState VFS
vfs (State VFS [WithSeverity VfsLog] -> ([WithSeverity VfsLog], VFS))
-> State VFS [WithSeverity VfsLog] -> ([WithSeverity VfsLog], VFS)
forall a b. (a -> b) -> a -> b
$ WriterT [WithSeverity VfsLog] (State VFS) ()
-> State VFS [WithSeverity VfsLog]
forall (m :: * -> *) w a. Monad m => WriterT w m a -> m w
execWriterT (WriterT [WithSeverity VfsLog] (State VFS) ()
 -> State VFS [WithSeverity VfsLog])
-> WriterT [WithSeverity VfsLog] (State VFS) ()
-> State VFS [WithSeverity VfsLog]
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)
  (WithSeverity VfsLog -> m ()) -> [WithSeverity VfsLog] -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\WithSeverity VfsLog
l -> LogAction m (WithSeverity LspProcessingLog)
logger LogAction m (WithSeverity LspProcessingLog)
-> WithSeverity LspProcessingLog -> m ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& (VfsLog -> LspProcessingLog)
-> WithSeverity VfsLog -> WithSeverity LspProcessingLog
forall a b. (a -> b) -> WithSeverity a -> WithSeverity b
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 = (WithSeverity VfsLog -> n ()) -> LogAction n (WithSeverity VfsLog)
forall (m :: * -> *) msg. (msg -> m ()) -> LogAction m msg
LogAction ((WithSeverity VfsLog -> n ())
 -> LogAction n (WithSeverity VfsLog))
-> (WithSeverity VfsLog -> n ())
-> LogAction n (WithSeverity VfsLog)
forall a b. (a -> b) -> a -> b
$ \WithSeverity VfsLog
m -> [WithSeverity VfsLog] -> n ()
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
_ SClientMethod
  @'Notification 'Method_WorkspaceDidChangeWorkspaceFolders
_ MessageParams
  @'ClientToServer
  @'Notification
  'Method_WorkspaceDidChangeWorkspaceFolders
params) = do
  let toRemove :: [WorkspaceFolder]
toRemove = DidChangeWorkspaceFoldersParams
MessageParams
  @'ClientToServer
  @'Notification
  'Method_WorkspaceDidChangeWorkspaceFolders
params DidChangeWorkspaceFoldersParams
-> Getting
     [WorkspaceFolder] DidChangeWorkspaceFoldersParams [WorkspaceFolder]
-> [WorkspaceFolder]
forall s a. s -> Getting a s a -> a
^. (WorkspaceFoldersChangeEvent
 -> Const @(*) [WorkspaceFolder] WorkspaceFoldersChangeEvent)
-> DidChangeWorkspaceFoldersParams
-> Const @(*) [WorkspaceFolder] DidChangeWorkspaceFoldersParams
forall s a. HasEvent s a => Lens' s a
Lens' DidChangeWorkspaceFoldersParams WorkspaceFoldersChangeEvent
L.event ((WorkspaceFoldersChangeEvent
  -> Const @(*) [WorkspaceFolder] WorkspaceFoldersChangeEvent)
 -> DidChangeWorkspaceFoldersParams
 -> Const @(*) [WorkspaceFolder] DidChangeWorkspaceFoldersParams)
-> (([WorkspaceFolder]
     -> Const @(*) [WorkspaceFolder] [WorkspaceFolder])
    -> WorkspaceFoldersChangeEvent
    -> Const @(*) [WorkspaceFolder] WorkspaceFoldersChangeEvent)
-> Getting
     [WorkspaceFolder] DidChangeWorkspaceFoldersParams [WorkspaceFolder]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([WorkspaceFolder]
 -> Const @(*) [WorkspaceFolder] [WorkspaceFolder])
-> WorkspaceFoldersChangeEvent
-> Const @(*) [WorkspaceFolder] WorkspaceFoldersChangeEvent
forall s a. HasRemoved s a => Lens' s a
Lens' WorkspaceFoldersChangeEvent [WorkspaceFolder]
L.removed
      toAdd :: [WorkspaceFolder]
toAdd = DidChangeWorkspaceFoldersParams
MessageParams
  @'ClientToServer
  @'Notification
  'Method_WorkspaceDidChangeWorkspaceFolders
params DidChangeWorkspaceFoldersParams
-> Getting
     [WorkspaceFolder] DidChangeWorkspaceFoldersParams [WorkspaceFolder]
-> [WorkspaceFolder]
forall s a. s -> Getting a s a -> a
^. (WorkspaceFoldersChangeEvent
 -> Const @(*) [WorkspaceFolder] WorkspaceFoldersChangeEvent)
-> DidChangeWorkspaceFoldersParams
-> Const @(*) [WorkspaceFolder] DidChangeWorkspaceFoldersParams
forall s a. HasEvent s a => Lens' s a
Lens' DidChangeWorkspaceFoldersParams WorkspaceFoldersChangeEvent
L.event ((WorkspaceFoldersChangeEvent
  -> Const @(*) [WorkspaceFolder] WorkspaceFoldersChangeEvent)
 -> DidChangeWorkspaceFoldersParams
 -> Const @(*) [WorkspaceFolder] DidChangeWorkspaceFoldersParams)
-> (([WorkspaceFolder]
     -> Const @(*) [WorkspaceFolder] [WorkspaceFolder])
    -> WorkspaceFoldersChangeEvent
    -> Const @(*) [WorkspaceFolder] WorkspaceFoldersChangeEvent)
-> Getting
     [WorkspaceFolder] DidChangeWorkspaceFoldersParams [WorkspaceFolder]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([WorkspaceFolder]
 -> Const @(*) [WorkspaceFolder] [WorkspaceFolder])
-> WorkspaceFoldersChangeEvent
-> Const @(*) [WorkspaceFolder] WorkspaceFoldersChangeEvent
forall s a. HasAdded s a => Lens' s a
Lens' WorkspaceFoldersChangeEvent [WorkspaceFolder]
L.added
      newWfs :: [WorkspaceFolder] -> [WorkspaceFolder]
newWfs [WorkspaceFolder]
oldWfs = (WorkspaceFolder -> [WorkspaceFolder] -> [WorkspaceFolder])
-> [WorkspaceFolder] -> [WorkspaceFolder] -> [WorkspaceFolder]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr WorkspaceFolder -> [WorkspaceFolder] -> [WorkspaceFolder]
forall a. Eq a => a -> [a] -> [a]
delete [WorkspaceFolder]
oldWfs [WorkspaceFolder]
toRemove [WorkspaceFolder] -> [WorkspaceFolder] -> [WorkspaceFolder]
forall a. Semigroup a => a -> a -> a
<> [WorkspaceFolder]
toAdd
  (LanguageContextState config -> TVar [WorkspaceFolder])
-> ([WorkspaceFolder] -> [WorkspaceFolder]) -> LspM config ()
forall config (m :: * -> *) a.
MonadLsp config m =>
(LanguageContextState config -> TVar a) -> (a -> a) -> m ()
modifyState LanguageContextState config -> TVar [WorkspaceFolder]
forall config.
LanguageContextState config -> TVar [WorkspaceFolder]
resWorkspaceFolders [WorkspaceFolder] -> [WorkspaceFolder]
newWfs

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