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

{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
-- So we can keep using the old prettyprinter modules (which have a better
-- compatibility range) for now.
{-# OPTIONS_GHC -Wno-deprecations #-}

module Language.LSP.Server.Processing where

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

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

data LspProcessingLog =
  VfsLog VfsLog
  | MessageProcessingError BSL.ByteString String
  | forall m . MissingHandler Bool (SClientMethod m)
  | ConfigurationParseError Value T.Text
  | ProgressCancel ProgressToken
  | Exiting

deriving instance Show LspProcessingLog

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

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

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

-- | Call this to initialize the session
initializeRequestHandler
  :: ServerDefinition config
  -> VFS
  -> (FromServerMessage -> IO ())
  -> Message Initialize
  -> IO (Maybe (LanguageContextEnv config))
initializeRequestHandler :: forall config.
ServerDefinition config
-> VFS
-> (FromServerMessage -> IO ())
-> Message @'FromClient @'Request 'Initialize
-> IO (Maybe (LanguageContextEnv config))
initializeRequestHandler ServerDefinition{config
Options
Handlers m
config -> Value -> Either Text config
a -> (<~>) @(*) m IO
LanguageContextEnv config
-> Message @'FromClient @'Request 'Initialize
-> IO (Either ResponseError a)
options :: forall config. ServerDefinition config -> Options
interpretHandler :: ()
staticHandlers :: ()
doInitialize :: ()
onConfigurationChange :: forall config.
ServerDefinition config -> config -> Value -> Either Text config
defaultConfig :: forall config. ServerDefinition config -> config
options :: Options
interpretHandler :: a -> (<~>) @(*) m IO
staticHandlers :: Handlers m
doInitialize :: LanguageContextEnv config
-> Message @'FromClient @'Request 'Initialize
-> IO (Either ResponseError a)
onConfigurationChange :: config -> Value -> Either Text config
defaultConfig :: config
..} VFS
vfs FromServerMessage -> IO ()
sendFunc Message @'FromClient @'Request 'Initialize
req = do
  let sendResp :: ResponseMessage @'FromClient 'Initialize -> IO ()
sendResp = FromServerMessage -> IO ()
sendFunc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: Method 'FromClient 'Request)
       (a :: Method 'FromClient 'Request -> *).
a m -> ResponseMessage @'FromClient m -> FromServerMessage' a
FromServerRsp SMethod @'FromClient @'Request 'Initialize
SInitialize
      handleErr :: Either ResponseError (LanguageContextEnv config)
-> IO (Maybe (LanguageContextEnv config))
handleErr (Left ResponseError
err) = do
        ResponseMessage @'FromClient 'Initialize -> IO ()
sendResp forall a b. (a -> b) -> a -> b
$ forall {f :: From} {m :: Method f 'Request}.
LspId @f m -> ResponseError -> ResponseMessage @f m
makeResponseError (Message @'FromClient @'Request 'Initialize
req forall s a. s -> Getting a s a -> a
^. forall s a. HasId s a => Lens' s a
LSP.id) ResponseError
err
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
      handleErr (Right LanguageContextEnv config
a) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just LanguageContextEnv config
a
  forall a b c. (a -> b -> c) -> b -> a -> c
flip forall e a. Exception e => IO a -> (e -> IO a) -> IO a
E.catch (forall a. (ResponseError -> IO ()) -> SomeException -> IO (Maybe a)
initializeErrorHandler forall a b. (a -> b) -> a -> b
$ ResponseMessage @'FromClient 'Initialize -> IO ()
sendResp forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {f :: From} {m :: Method f 'Request}.
LspId @f m -> ResponseError -> ResponseMessage @f m
makeResponseError (Message @'FromClient @'Request 'Initialize
req forall s a. s -> Getting a s a -> a
^. forall s a. HasId s a => Lens' s a
LSP.id)) forall a b. (a -> b) -> a -> b
$ Either ResponseError (LanguageContextEnv config)
-> IO (Maybe (LanguageContextEnv config))
handleErr forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ mdo

    let params :: InitializeParams
params = Message @'FromClient @'Request 'Initialize
req forall s a. s -> Getting a s a -> a
^. forall s a. HasParams s a => Lens' s a
LSP.params
        rootDir :: Maybe String
rootDir = forall a. First a -> Maybe a
getFirst forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall a. Maybe a -> First a
First [ InitializeParams
params forall s a. s -> Getting a s a -> a
^. forall s a. HasRootUri s a => Lens' s a
LSP.rootUri  forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Uri -> Maybe String
uriToFilePath
                                           , InitializeParams
params forall s a. s -> Getting a s a -> a
^. forall s a. HasRootPath s a => Lens' s a
LSP.rootPath forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Text -> String
T.unpack ]

    let initialWfs :: [WorkspaceFolder]
initialWfs = case InitializeParams
params forall s a. s -> Getting a s a -> a
^. forall s a. HasWorkspaceFolders s a => Lens' s a
LSP.workspaceFolders of
          Just (List [WorkspaceFolder]
xs) -> [WorkspaceFolder]
xs
          Maybe (List WorkspaceFolder)
Nothing -> []

        initialConfig :: config
initialConfig = case config -> Value -> Either Text config
onConfigurationChange config
defaultConfig forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Message @'FromClient @'Request 'Initialize
req forall s a. s -> Getting a s a -> a
^. forall s a. HasParams s a => Lens' s a
LSP.params forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasInitializationOptions s a => Lens' s a
LSP.initializationOptions) of
          Just (Right config
newConfig) -> config
newConfig
          Maybe (Either Text config)
_ -> config
defaultConfig

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

    -- Call the 'duringInitialization' callback to let the server kick stuff up
    let env :: LanguageContextEnv config
env = forall config.
Handlers IO
-> (config -> Value -> Either Text config)
-> (FromServerMessage -> IO ())
-> LanguageContextState config
-> ClientCapabilities
-> Maybe String
-> LanguageContextEnv config
LanguageContextEnv Handlers IO
handlers config -> Value -> Either Text config
onConfigurationChange FromServerMessage -> IO ()
sendFunc LanguageContextState config
stateVars (InitializeParams
params forall s a. s -> Getting a s a -> a
^. forall s a. HasCapabilities s a => Lens' s a
LSP.capabilities) Maybe String
rootDir
        handlers :: Handlers IO
handlers = forall (m :: * -> *) (n :: * -> *).
(<~>) @(*) m n -> Handlers m -> Handlers n
transmuteHandlers (<~>) @(*) m IO
interpreter Handlers m
staticHandlers
        interpreter :: (<~>) @(*) m IO
interpreter = a -> (<~>) @(*) m IO
interpretHandler a
initializationResult
    a
initializationResult <- forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ LanguageContextEnv config
-> Message @'FromClient @'Request 'Initialize
-> IO (Either ResponseError a)
doInitialize LanguageContextEnv config
env Message @'FromClient @'Request 'Initialize
req

    let serverCaps :: ServerCapabilities
serverCaps = forall (m :: * -> *).
ClientCapabilities -> Options -> Handlers m -> ServerCapabilities
inferServerCapabilities (InitializeParams
params forall s a. s -> Getting a s a -> a
^. forall s a. HasCapabilities s a => Lens' s a
LSP.capabilities) Options
options Handlers IO
handlers
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ResponseMessage @'FromClient 'Initialize -> IO ()
sendResp forall a b. (a -> b) -> a -> b
$ forall {f :: From} {m :: Method f 'Request}.
LspId @f m -> ResponseResult @f m -> ResponseMessage @f m
makeResponseMessage (Message @'FromClient @'Request 'Initialize
req forall s a. s -> Getting a s a -> a
^. forall s a. HasId s a => Lens' s a
LSP.id) (ServerCapabilities -> Maybe ServerInfo -> InitializeResult
InitializeResult ServerCapabilities
serverCaps (Options -> Maybe ServerInfo
serverInfo Options
options))
    forall (f :: * -> *) a. Applicative f => a -> f a
pure LanguageContextEnv config
env
  where
    makeResponseMessage :: LspId @f m -> ResponseResult @f m -> ResponseMessage @f m
makeResponseMessage LspId @f m
rid ResponseResult @f m
result = forall (f :: From) (m :: Method f 'Request).
Text
-> Maybe (LspId @f m)
-> Either ResponseError (ResponseResult @f m)
-> ResponseMessage @f m
ResponseMessage Text
"2.0" (forall a. a -> Maybe a
Just LspId @f m
rid) (forall a b. b -> Either a b
Right ResponseResult @f m
result)
    makeResponseError :: LspId @f m -> ResponseError -> ResponseMessage @f m
makeResponseError LspId @f m
origId ResponseError
err = forall (f :: From) (m :: Method f 'Request).
Text
-> Maybe (LspId @f m)
-> Either ResponseError (ResponseResult @f m)
-> ResponseMessage @f m
ResponseMessage Text
"2.0" (forall a. a -> Maybe a
Just LspId @f m
origId) (forall a b. a -> Either a b
Left ResponseError
err)

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


-- | Infers the capabilities based on registered handlers, and sets the appropriate options.
-- A provider should be set to Nothing if the server does not support it, unless it is a
-- static option.
inferServerCapabilities :: ClientCapabilities -> Options -> Handlers m -> ServerCapabilities
inferServerCapabilities :: forall (m :: * -> *).
ClientCapabilities -> Options -> Handlers m -> ServerCapabilities
inferServerCapabilities ClientCapabilities
clientCaps Options
o Handlers m
h =
  ServerCapabilities
    { $sel:_textDocumentSync:ServerCapabilities :: Maybe (TextDocumentSyncOptions |? TextDocumentSyncKind)
_textDocumentSync                 = Maybe (TextDocumentSyncOptions |? TextDocumentSyncKind)
sync
    , $sel:_hoverProvider:ServerCapabilities :: Maybe (Bool |? HoverOptions)
_hoverProvider                    = forall {t :: MethodType} {m :: Method 'FromClient t} {b}.
SClientMethod @t m -> Maybe (Bool |? b)
supportedBool SMethod @'FromClient @'Request 'TextDocumentHover
STextDocumentHover
    , $sel:_completionProvider:ServerCapabilities :: Maybe CompletionOptions
_completionProvider               = Maybe CompletionOptions
completionProvider
    , $sel:_declarationProvider:ServerCapabilities :: Maybe
  (Bool |? (DeclarationOptions |? DeclarationRegistrationOptions))
_declarationProvider              = forall {t :: MethodType} {m :: Method 'FromClient t} {b}.
SClientMethod @t m -> Maybe (Bool |? b)
supportedBool SMethod @'FromClient @'Request 'TextDocumentDeclaration
STextDocumentDeclaration
    , $sel:_signatureHelpProvider:ServerCapabilities :: Maybe SignatureHelpOptions
_signatureHelpProvider            = Maybe SignatureHelpOptions
signatureHelpProvider
    , $sel:_definitionProvider:ServerCapabilities :: Maybe (Bool |? DefinitionOptions)
_definitionProvider               = forall {t :: MethodType} {m :: Method 'FromClient t} {b}.
SClientMethod @t m -> Maybe (Bool |? b)
supportedBool SMethod @'FromClient @'Request 'TextDocumentDefinition
STextDocumentDefinition
    , $sel:_typeDefinitionProvider:ServerCapabilities :: Maybe
  (Bool
   |? (TypeDefinitionOptions |? TypeDefinitionRegistrationOptions))
_typeDefinitionProvider           = forall {t :: MethodType} {m :: Method 'FromClient t} {b}.
SClientMethod @t m -> Maybe (Bool |? b)
supportedBool SMethod @'FromClient @'Request 'TextDocumentTypeDefinition
STextDocumentTypeDefinition
    , $sel:_implementationProvider:ServerCapabilities :: Maybe
  (Bool
   |? (ImplementationOptions |? ImplementationRegistrationOptions))
_implementationProvider           = forall {t :: MethodType} {m :: Method 'FromClient t} {b}.
SClientMethod @t m -> Maybe (Bool |? b)
supportedBool SMethod @'FromClient @'Request 'TextDocumentImplementation
STextDocumentImplementation
    , $sel:_referencesProvider:ServerCapabilities :: Maybe (Bool |? ReferenceOptions)
_referencesProvider               = forall {t :: MethodType} {m :: Method 'FromClient t} {b}.
SClientMethod @t m -> Maybe (Bool |? b)
supportedBool SMethod @'FromClient @'Request 'TextDocumentReferences
STextDocumentReferences
    , $sel:_documentHighlightProvider:ServerCapabilities :: Maybe (Bool |? DocumentHighlightOptions)
_documentHighlightProvider        = forall {t :: MethodType} {m :: Method 'FromClient t} {b}.
SClientMethod @t m -> Maybe (Bool |? b)
supportedBool SMethod @'FromClient @'Request 'TextDocumentDocumentHighlight
STextDocumentDocumentHighlight
    , $sel:_documentSymbolProvider:ServerCapabilities :: Maybe (Bool |? DocumentSymbolOptions)
_documentSymbolProvider           = forall {t :: MethodType} {m :: Method 'FromClient t} {b}.
SClientMethod @t m -> Maybe (Bool |? b)
supportedBool SMethod @'FromClient @'Request 'TextDocumentDocumentSymbol
STextDocumentDocumentSymbol
    , $sel:_codeActionProvider:ServerCapabilities :: Maybe (Bool |? CodeActionOptions)
_codeActionProvider               = Maybe (Bool |? CodeActionOptions)
codeActionProvider
    , $sel:_codeLensProvider:ServerCapabilities :: Maybe CodeLensOptions
_codeLensProvider                 = forall {t :: MethodType} {m :: Method 'FromClient t} {a}.
SClientMethod @t m -> a -> Maybe a
supported' SMethod @'FromClient @'Request 'TextDocumentCodeLens
STextDocumentCodeLens forall a b. (a -> b) -> a -> b
$ Maybe Bool -> Maybe Bool -> CodeLensOptions
CodeLensOptions
                                              (forall a. a -> Maybe a
Just Bool
False)
                                              (forall {t :: MethodType} (m :: Method 'FromClient t).
SClientMethod @t m -> Maybe Bool
supported SMethod @'FromClient @'Request 'CodeLensResolve
SCodeLensResolve)
    , $sel:_documentFormattingProvider:ServerCapabilities :: Maybe (Bool |? DocumentFormattingOptions)
_documentFormattingProvider       = forall {t :: MethodType} {m :: Method 'FromClient t} {b}.
SClientMethod @t m -> Maybe (Bool |? b)
supportedBool SMethod @'FromClient @'Request 'TextDocumentFormatting
STextDocumentFormatting
    , $sel:_documentRangeFormattingProvider:ServerCapabilities :: Maybe (Bool |? DocumentRangeFormattingOptions)
_documentRangeFormattingProvider  = forall {t :: MethodType} {m :: Method 'FromClient t} {b}.
SClientMethod @t m -> Maybe (Bool |? b)
supportedBool SMethod @'FromClient @'Request 'TextDocumentRangeFormatting
STextDocumentRangeFormatting
    , $sel:_documentOnTypeFormattingProvider:ServerCapabilities :: Maybe DocumentOnTypeFormattingOptions
_documentOnTypeFormattingProvider = Maybe DocumentOnTypeFormattingOptions
documentOnTypeFormattingProvider
    , $sel:_renameProvider:ServerCapabilities :: Maybe (Bool |? RenameOptions)
_renameProvider                   = Maybe (Bool |? RenameOptions)
renameProvider
    , $sel:_documentLinkProvider:ServerCapabilities :: Maybe DocumentLinkOptions
_documentLinkProvider             = forall {t :: MethodType} {m :: Method 'FromClient t} {a}.
SClientMethod @t m -> a -> Maybe a
supported' SMethod @'FromClient @'Request 'TextDocumentDocumentLink
STextDocumentDocumentLink forall a b. (a -> b) -> a -> b
$ Maybe Bool -> Maybe Bool -> DocumentLinkOptions
DocumentLinkOptions
                                              (forall a. a -> Maybe a
Just Bool
False)
                                              (forall {t :: MethodType} (m :: Method 'FromClient t).
SClientMethod @t m -> Maybe Bool
supported SMethod @'FromClient @'Request 'DocumentLinkResolve
SDocumentLinkResolve)
    , $sel:_colorProvider:ServerCapabilities :: Maybe
  (Bool
   |? (DocumentColorOptions |? DocumentColorRegistrationOptions))
_colorProvider                    = forall {t :: MethodType} {m :: Method 'FromClient t} {b}.
SClientMethod @t m -> Maybe (Bool |? b)
supportedBool SMethod @'FromClient @'Request 'TextDocumentDocumentColor
STextDocumentDocumentColor
    , $sel:_foldingRangeProvider:ServerCapabilities :: Maybe
  (Bool |? (FoldingRangeOptions |? FoldingRangeRegistrationOptions))
_foldingRangeProvider             = forall {t :: MethodType} {m :: Method 'FromClient t} {b}.
SClientMethod @t m -> Maybe (Bool |? b)
supportedBool SMethod @'FromClient @'Request 'TextDocumentFoldingRange
STextDocumentFoldingRange
    , $sel:_executeCommandProvider:ServerCapabilities :: Maybe ExecuteCommandOptions
_executeCommandProvider           = Maybe ExecuteCommandOptions
executeCommandProvider
    , $sel:_selectionRangeProvider:ServerCapabilities :: Maybe
  (Bool
   |? (SelectionRangeOptions |? SelectionRangeRegistrationOptions))
_selectionRangeProvider           = forall {t :: MethodType} {m :: Method 'FromClient t} {b}.
SClientMethod @t m -> Maybe (Bool |? b)
supportedBool SMethod @'FromClient @'Request 'TextDocumentSelectionRange
STextDocumentSelectionRange
    , $sel:_callHierarchyProvider:ServerCapabilities :: Maybe
  (Bool
   |? (CallHierarchyOptions |? CallHierarchyRegistrationOptions))
_callHierarchyProvider            = forall {t :: MethodType} {m :: Method 'FromClient t} {b}.
SClientMethod @t m -> Maybe (Bool |? b)
supportedBool SMethod @'FromClient @'Request 'TextDocumentPrepareCallHierarchy
STextDocumentPrepareCallHierarchy
    , $sel:_semanticTokensProvider:ServerCapabilities :: Maybe (SemanticTokensOptions |? SemanticTokensRegistrationOptions)
_semanticTokensProvider           = forall {b}. Maybe (SemanticTokensOptions |? b)
semanticTokensProvider
    , $sel:_workspaceSymbolProvider:ServerCapabilities :: Maybe (Bool |? WorkspaceSymbolOptions)
_workspaceSymbolProvider          = forall {t :: MethodType} {m :: Method 'FromClient t} {b}.
SClientMethod @t m -> Maybe (Bool |? b)
supportedBool SMethod @'FromClient @'Request 'WorkspaceSymbol
SWorkspaceSymbol
    , $sel:_workspace:ServerCapabilities :: Maybe WorkspaceServerCapabilities
_workspace                        = forall a. a -> Maybe a
Just WorkspaceServerCapabilities
workspace
    -- TODO: Add something for experimental
    , $sel:_experimental:ServerCapabilities :: Maybe Value
_experimental                     = forall a. Maybe a
Nothing :: Maybe Value
    }
  where

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

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

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

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

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

    completionProvider :: Maybe CompletionOptions
completionProvider
      | forall {t :: MethodType} (m :: Method 'FromClient t).
SClientMethod @t m -> Bool
supported_b SMethod @'FromClient @'Request 'TextDocumentCompletion
STextDocumentCompletion = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
          Maybe Bool
-> Maybe [Text] -> Maybe [Text] -> Maybe Bool -> CompletionOptions
CompletionOptions
            forall a. Maybe a
Nothing
            (forall a b. (a -> b) -> [a] -> [b]
map Char -> Text
T.singleton forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Options -> Maybe String
completionTriggerCharacters Options
o)
            (forall a b. (a -> b) -> [a] -> [b]
map Char -> Text
T.singleton forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Options -> Maybe String
completionAllCommitCharacters Options
o)
            (forall {t :: MethodType} (m :: Method 'FromClient t).
SClientMethod @t m -> Maybe Bool
supported SMethod @'FromClient @'Request 'CompletionItemResolve
SCompletionItemResolve)
      | Bool
otherwise = forall a. Maybe a
Nothing

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

    codeActionProvider :: Maybe (Bool |? CodeActionOptions)
codeActionProvider
      | Bool
clientSupportsCodeActionKinds
      , forall {t :: MethodType} (m :: Method 'FromClient t).
SClientMethod @t m -> Bool
supported_b SMethod @'FromClient @'Request 'TextDocumentCodeAction
STextDocumentCodeAction = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ case Options -> Maybe [CodeActionKind]
codeActionKinds Options
o of
          Just [CodeActionKind]
ks -> forall a b. b -> a |? b
InR forall a b. (a -> b) -> a -> b
$ Maybe Bool
-> Maybe (List CodeActionKind) -> Maybe Bool -> CodeActionOptions
CodeActionOptions forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just (forall a. [a] -> List a
List [CodeActionKind]
ks)) (forall {t :: MethodType} (m :: Method 'FromClient t).
SClientMethod @t m -> Maybe Bool
supported SMethod @'FromClient @'Request 'CodeLensResolve
SCodeLensResolve)
          Maybe [CodeActionKind]
Nothing -> forall a b. a -> a |? b
InL Bool
True
      | forall {t :: MethodType} (m :: Method 'FromClient t).
SClientMethod @t m -> Bool
supported_b SMethod @'FromClient @'Request 'TextDocumentCodeAction
STextDocumentCodeAction = forall a. a -> Maybe a
Just (forall a b. a -> a |? b
InL Bool
True)
      | Bool
otherwise = forall a. a -> Maybe a
Just (forall a b. a -> a |? b
InL Bool
False)

    signatureHelpProvider :: Maybe SignatureHelpOptions
signatureHelpProvider
      | forall {t :: MethodType} (m :: Method 'FromClient t).
SClientMethod @t m -> Bool
supported_b SMethod @'FromClient @'Request 'TextDocumentSignatureHelp
STextDocumentSignatureHelp = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
          Maybe Bool
-> Maybe (List Text) -> Maybe (List Text) -> SignatureHelpOptions
SignatureHelpOptions
            forall a. Maybe a
Nothing
            (forall a. [a] -> List a
List forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Char -> Text
T.singleton forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Options -> Maybe String
signatureHelpTriggerCharacters Options
o)
            (forall a. [a] -> List a
List forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Char -> Text
T.singleton forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Options -> Maybe String
signatureHelpRetriggerCharacters Options
o)
      | Bool
otherwise = forall a. Maybe a
Nothing

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

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

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

    renameProvider :: Maybe (Bool |? RenameOptions)
renameProvider
      | Bool
clientSupportsPrepareRename
      , forall {t :: MethodType} (m :: Method 'FromClient t).
SClientMethod @t m -> Bool
supported_b SMethod @'FromClient @'Request 'TextDocumentRename
STextDocumentRename
      , forall {t :: MethodType} (m :: Method 'FromClient t).
SClientMethod @t m -> Bool
supported_b SMethod @'FromClient @'Request 'TextDocumentPrepareRename
STextDocumentPrepareRename = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
          forall a b. b -> a |? b
InR forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Bool -> Maybe Bool -> RenameOptions
RenameOptions forall a. Maybe a
Nothing forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Bool
True
      | forall {t :: MethodType} (m :: Method 'FromClient t).
SClientMethod @t m -> Bool
supported_b SMethod @'FromClient @'Request 'TextDocumentRename
STextDocumentRename = forall a. a -> Maybe a
Just (forall a b. a -> a |? b
InL Bool
True)
      | Bool
otherwise = forall a. a -> Maybe a
Just (forall a b. a -> a |? b
InL Bool
False)

    -- Always provide the default legend
    -- TODO: allow user-provided legend via 'Options', or at least user-provided types
    semanticTokensProvider :: Maybe (SemanticTokensOptions |? b)
semanticTokensProvider = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. a -> a |? b
InL forall a b. (a -> b) -> a -> b
$ Maybe Bool
-> SemanticTokensLegend
-> Maybe SemanticTokensRangeClientCapabilities
-> Maybe SemanticTokensFullClientCapabilities
-> SemanticTokensOptions
SemanticTokensOptions forall a. Maybe a
Nothing forall a. Default a => a
def Maybe SemanticTokensRangeClientCapabilities
semanticTokenRangeProvider Maybe SemanticTokensFullClientCapabilities
semanticTokenFullProvider
    semanticTokenRangeProvider :: Maybe SemanticTokensRangeClientCapabilities
semanticTokenRangeProvider
      | forall {t :: MethodType} (m :: Method 'FromClient t).
SClientMethod @t m -> Bool
supported_b SMethod @'FromClient @'Request 'TextDocumentSemanticTokensRange
STextDocumentSemanticTokensRange = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Bool -> SemanticTokensRangeClientCapabilities
SemanticTokensRangeBool Bool
True
      | Bool
otherwise = forall a. Maybe a
Nothing
    semanticTokenFullProvider :: Maybe SemanticTokensFullClientCapabilities
semanticTokenFullProvider
      | forall {t :: MethodType} (m :: Method 'FromClient t).
SClientMethod @t m -> Bool
supported_b SMethod @'FromClient @'Request 'TextDocumentSemanticTokensFull
STextDocumentSemanticTokensFull = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ SemanticTokensDeltaClientCapabilities
-> SemanticTokensFullClientCapabilities
SemanticTokensFullDelta forall a b. (a -> b) -> a -> b
$ Maybe Bool -> SemanticTokensDeltaClientCapabilities
SemanticTokensDeltaClientCapabilities forall a b. (a -> b) -> a -> b
$ forall {t :: MethodType} (m :: Method 'FromClient t).
SClientMethod @t m -> Maybe Bool
supported SMethod @'FromClient @'Request 'TextDocumentSemanticTokensFullDelta
STextDocumentSemanticTokensFullDelta
      | Bool
otherwise = forall a. Maybe a
Nothing

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

    workspace :: WorkspaceServerCapabilities
workspace = Maybe WorkspaceFoldersServerCapabilities
-> WorkspaceServerCapabilities
WorkspaceServerCapabilities Maybe WorkspaceFoldersServerCapabilities
workspaceFolder
    workspaceFolder :: Maybe WorkspaceFoldersServerCapabilities
workspaceFolder = forall {t :: MethodType} {m :: Method 'FromClient t} {a}.
SClientMethod @t m -> a -> Maybe a
supported' SMethod
  @'FromClient @'Notification 'WorkspaceDidChangeWorkspaceFolders
SWorkspaceDidChangeWorkspaceFolders forall a b. (a -> b) -> a -> b
$
        -- sign up to receive notifications
        Maybe Bool
-> Maybe (Text |? Bool) -> WorkspaceFoldersServerCapabilities
WorkspaceFoldersServerCapabilities (forall a. a -> Maybe a
Just Bool
True) (forall a. a -> Maybe a
Just (forall a b. b -> a |? b
InR Bool
True))

-- | Invokes the registered dynamic or static handlers for the given message and
-- method, as well as doing some bookkeeping.
handle :: (m ~ LspM config) => LogAction m (WithSeverity LspProcessingLog) -> SClientMethod meth -> ClientMessage meth -> m ()
handle :: forall {t :: MethodType} (m :: * -> *) config
       (meth :: Method 'FromClient t).
((m :: (* -> *)) ~ (LspM config :: (* -> *))) =>
LogAction m (WithSeverity LspProcessingLog)
-> SClientMethod @t meth -> ClientMessage @t meth -> m ()
handle LogAction m (WithSeverity LspProcessingLog)
logger SClientMethod @t meth
m ClientMessage @t meth
msg =
  case SClientMethod @t meth
m of
    SClientMethod @t meth
SWorkspaceDidChangeWorkspaceFolders -> forall (m :: * -> *) (t :: MethodType)
       (meth :: Method 'FromClient t) config.
((m :: (* -> *)) ~ (LspM config :: (* -> *))) =>
LogAction m (WithSeverity LspProcessingLog)
-> Maybe (ClientMessage @t meth -> m ())
-> SClientMethod @t meth
-> ClientMessage @t meth
-> m ()
handle' LogAction m (WithSeverity LspProcessingLog)
logger (forall a. a -> Maybe a
Just forall config.
Message
  @'FromClient @'Notification 'WorkspaceDidChangeWorkspaceFolders
-> LspM config ()
updateWorkspaceFolders) SClientMethod @t meth
m ClientMessage @t meth
msg
    SClientMethod @t meth
SWorkspaceDidChangeConfiguration    -> forall (m :: * -> *) (t :: MethodType)
       (meth :: Method 'FromClient t) config.
((m :: (* -> *)) ~ (LspM config :: (* -> *))) =>
LogAction m (WithSeverity LspProcessingLog)
-> Maybe (ClientMessage @t meth -> m ())
-> SClientMethod @t meth
-> ClientMessage @t meth
-> m ()
handle' LogAction m (WithSeverity LspProcessingLog)
logger (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) config.
((m :: (* -> *)) ~ (LspM config :: (* -> *))) =>
LogAction m (WithSeverity LspProcessingLog)
-> Message
     @'FromClient @'Notification 'WorkspaceDidChangeConfiguration
-> m ()
handleConfigChange LogAction m (WithSeverity LspProcessingLog)
logger) SClientMethod @t meth
m ClientMessage @t meth
msg
    SClientMethod @t meth
STextDocumentDidOpen                -> forall (m :: * -> *) (t :: MethodType)
       (meth :: Method 'FromClient t) config.
((m :: (* -> *)) ~ (LspM config :: (* -> *))) =>
LogAction m (WithSeverity LspProcessingLog)
-> Maybe (ClientMessage @t meth -> m ())
-> SClientMethod @t meth
-> ClientMessage @t meth
-> m ()
handle' LogAction m (WithSeverity LspProcessingLog)
logger (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (n :: * -> *) a config.
((m :: (* -> *)) ~ (LspM config :: (* -> *)),
 (n :: (* -> *))
 ~ (WriterT [WithSeverity VfsLog] (State VFS) :: (* -> *))) =>
LogAction m (WithSeverity LspProcessingLog)
-> (LogAction n (WithSeverity VfsLog) -> a -> n ()) -> a -> m ()
vfsFunc LogAction m (WithSeverity LspProcessingLog)
logger forall (m :: * -> *).
MonadState VFS m =>
LogAction m (WithSeverity VfsLog)
-> Message @'FromClient @'Notification 'TextDocumentDidOpen -> m ()
openVFS) SClientMethod @t meth
m ClientMessage @t meth
msg
    SClientMethod @t meth
STextDocumentDidChange              -> forall (m :: * -> *) (t :: MethodType)
       (meth :: Method 'FromClient t) config.
((m :: (* -> *)) ~ (LspM config :: (* -> *))) =>
LogAction m (WithSeverity LspProcessingLog)
-> Maybe (ClientMessage @t meth -> m ())
-> SClientMethod @t meth
-> ClientMessage @t meth
-> m ()
handle' LogAction m (WithSeverity LspProcessingLog)
logger (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (n :: * -> *) a config.
((m :: (* -> *)) ~ (LspM config :: (* -> *)),
 (n :: (* -> *))
 ~ (WriterT [WithSeverity VfsLog] (State VFS) :: (* -> *))) =>
LogAction m (WithSeverity LspProcessingLog)
-> (LogAction n (WithSeverity VfsLog) -> a -> n ()) -> a -> m ()
vfsFunc LogAction m (WithSeverity LspProcessingLog)
logger forall (m :: * -> *).
MonadState VFS m =>
LogAction m (WithSeverity VfsLog)
-> Message @'FromClient @'Notification 'TextDocumentDidChange
-> m ()
changeFromClientVFS) SClientMethod @t meth
m ClientMessage @t meth
msg
    SClientMethod @t meth
STextDocumentDidClose               -> forall (m :: * -> *) (t :: MethodType)
       (meth :: Method 'FromClient t) config.
((m :: (* -> *)) ~ (LspM config :: (* -> *))) =>
LogAction m (WithSeverity LspProcessingLog)
-> Maybe (ClientMessage @t meth -> m ())
-> SClientMethod @t meth
-> ClientMessage @t meth
-> m ()
handle' LogAction m (WithSeverity LspProcessingLog)
logger (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (n :: * -> *) a config.
((m :: (* -> *)) ~ (LspM config :: (* -> *)),
 (n :: (* -> *))
 ~ (WriterT [WithSeverity VfsLog] (State VFS) :: (* -> *))) =>
LogAction m (WithSeverity LspProcessingLog)
-> (LogAction n (WithSeverity VfsLog) -> a -> n ()) -> a -> m ()
vfsFunc LogAction m (WithSeverity LspProcessingLog)
logger forall (m :: * -> *).
MonadState VFS m =>
LogAction m (WithSeverity VfsLog)
-> Message @'FromClient @'Notification 'TextDocumentDidClose
-> m ()
closeVFS) SClientMethod @t meth
m ClientMessage @t meth
msg
    SClientMethod @t meth
SWindowWorkDoneProgressCancel       -> forall (m :: * -> *) (t :: MethodType)
       (meth :: Method 'FromClient t) config.
((m :: (* -> *)) ~ (LspM config :: (* -> *))) =>
LogAction m (WithSeverity LspProcessingLog)
-> Maybe (ClientMessage @t meth -> m ())
-> SClientMethod @t meth
-> ClientMessage @t meth
-> m ()
handle' LogAction m (WithSeverity LspProcessingLog)
logger (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) config.
((m :: (* -> *)) ~ (LspM config :: (* -> *))) =>
LogAction m (WithSeverity LspProcessingLog)
-> Message
     @'FromClient @'Notification 'WindowWorkDoneProgressCancel
-> m ()
progressCancelHandler LogAction m (WithSeverity LspProcessingLog)
logger) SClientMethod @t meth
m ClientMessage @t meth
msg
    SClientMethod @t meth
_ -> forall (m :: * -> *) (t :: MethodType)
       (meth :: Method 'FromClient t) config.
((m :: (* -> *)) ~ (LspM config :: (* -> *))) =>
LogAction m (WithSeverity LspProcessingLog)
-> Maybe (ClientMessage @t meth -> m ())
-> SClientMethod @t meth
-> ClientMessage @t meth
-> m ()
handle' LogAction m (WithSeverity LspProcessingLog)
logger forall a. Maybe a
Nothing SClientMethod @t meth
m ClientMessage @t meth
msg


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

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

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

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

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

    ClientNotOrReq @t meth
IsClientReq -> case RegistrationMap t
-> SMethodMap @'FromClient @t (ClientMessageHandler IO t)
-> Maybe (Handler @'FromClient @t IO meth)
pickHandler RegistrationMap 'Request
dynReqHandlers SMethodMap
  @'FromClient @'Request (ClientMessageHandler IO 'Request)
reqHandlers of
      Just Handler @'FromClient @t IO meth
h -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handler @'FromClient @t IO meth
h ClientMessage @t meth
msg (forall (m1 :: Method 'FromClient 'Request).
RequestMessage @'FromClient m1
-> Either ResponseError (ResponseResult @'FromClient m1) -> IO ()
mkRspCb ClientMessage @t meth
msg)
      Maybe (Handler @'FromClient @t IO meth)
Nothing
        | SClientMethod @t meth
SShutdown <- SClientMethod @t meth
m -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handler @'FromClient @'Request IO 'Shutdown
shutdownRequestHandler ClientMessage @t meth
msg (forall (m1 :: Method 'FromClient 'Request).
RequestMessage @'FromClient m1
-> Either ResponseError (ResponseResult @'FromClient m1) -> IO ()
mkRspCb ClientMessage @t meth
msg)
        | Bool
otherwise -> do
            let errorMsg :: Text
errorMsg = String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String
"lsp:no handler for: ", forall a. Show a => a -> String
show SClientMethod @t meth
m]
                err :: ResponseError
err = ErrorCode -> Text -> Maybe Value -> ResponseError
ResponseError ErrorCode
MethodNotFound Text
errorMsg forall a. Maybe a
Nothing
            forall config (m :: * -> *).
MonadLsp config m =>
FromServerMessage -> m ()
sendToClient forall a b. (a -> b) -> a -> b
$
              forall (m :: Method 'FromClient 'Request)
       (a :: Method 'FromClient 'Request -> *).
a m -> ResponseMessage @'FromClient m -> FromServerMessage' a
FromServerRsp (ClientMessage @t meth
msg forall s a. s -> Getting a s a -> a
^. forall s a. HasMethod s a => Lens' s a
LSP.method) forall a b. (a -> b) -> a -> b
$ forall (f :: From) (m :: Method f 'Request).
Text
-> Maybe (LspId @f m)
-> Either ResponseError (ResponseResult @f m)
-> ResponseMessage @f m
ResponseMessage Text
"2.0" (forall a. a -> Maybe a
Just (ClientMessage @t meth
msg forall s a. s -> Getting a s a -> a
^. forall s a. HasId s a => Lens' s a
LSP.id)) (forall a b. a -> Either a b
Left ResponseError
err)

    ClientNotOrReq @t meth
IsClientEither -> case ClientMessage @t meth
msg of
      NotMess NotificationMessage
  @'FromClient ('CustomMethod @'FromClient @'Notification)
noti -> case RegistrationMap t
-> SMethodMap @'FromClient @t (ClientMessageHandler IO t)
-> Maybe (Handler @'FromClient @t IO meth)
pickHandler RegistrationMap 'Notification
dynNotHandlers SMethodMap
  @'FromClient @'Notification (ClientMessageHandler IO 'Notification)
notHandlers of
        Just Handler @'FromClient @t IO meth
h -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handler @'FromClient @t IO meth
h NotificationMessage
  @'FromClient ('CustomMethod @'FromClient @'Notification)
noti
        Maybe (Handler @'FromClient @t IO meth)
Nothing -> m ()
reportMissingHandler
      ReqMess RequestMessage @'FromClient ('CustomMethod @'FromClient @'Request)
req -> case RegistrationMap t
-> SMethodMap @'FromClient @t (ClientMessageHandler IO t)
-> Maybe (Handler @'FromClient @t IO meth)
pickHandler RegistrationMap 'Request
dynReqHandlers SMethodMap
  @'FromClient @'Request (ClientMessageHandler IO 'Request)
reqHandlers of
        Just Handler @'FromClient @t IO meth
h -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handler @'FromClient @t IO meth
h RequestMessage @'FromClient ('CustomMethod @'FromClient @'Request)
req (forall (m1 :: Method 'FromClient 'Request).
RequestMessage @'FromClient m1
-> Either ResponseError (ResponseResult @'FromClient m1) -> IO ()
mkRspCb RequestMessage @'FromClient ('CustomMethod @'FromClient @'Request)
req)
        Maybe (Handler @'FromClient @t IO meth)
Nothing -> do
          let errorMsg :: Text
errorMsg = String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String
"lsp:no handler for: ", forall a. Show a => a -> String
show SClientMethod @t meth
m]
              err :: ResponseError
err = ErrorCode -> Text -> Maybe Value -> ResponseError
ResponseError ErrorCode
MethodNotFound Text
errorMsg forall a. Maybe a
Nothing
          forall config (m :: * -> *).
MonadLsp config m =>
FromServerMessage -> m ()
sendToClient forall a b. (a -> b) -> a -> b
$
            forall (m :: Method 'FromClient 'Request)
       (a :: Method 'FromClient 'Request -> *).
a m -> ResponseMessage @'FromClient m -> FromServerMessage' a
FromServerRsp (RequestMessage @'FromClient ('CustomMethod @'FromClient @'Request)
req forall s a. s -> Getting a s a -> a
^. forall s a. HasMethod s a => Lens' s a
LSP.method) forall a b. (a -> b) -> a -> b
$ forall (f :: From) (m :: Method f 'Request).
Text
-> Maybe (LspId @f m)
-> Either ResponseError (ResponseResult @f m)
-> ResponseMessage @f m
ResponseMessage Text
"2.0" (forall a. a -> Maybe a
Just (RequestMessage @'FromClient ('CustomMethod @'FromClient @'Request)
req forall s a. s -> Getting a s a -> a
^. forall s a. HasId s a => Lens' s a
LSP.id)) (forall a b. a -> Either a b
Left ResponseError
err)
  where
    -- | Checks to see if there's a dynamic handler, and uses it in favour of the
    -- static handler, if it exists.
    pickHandler :: RegistrationMap t -> SMethodMap (ClientMessageHandler IO t) -> Maybe (Handler IO meth)
    pickHandler :: RegistrationMap t
-> SMethodMap @'FromClient @t (ClientMessageHandler IO t)
-> Maybe (Handler @'FromClient @t IO meth)
pickHandler RegistrationMap t
dynHandlerMap SMethodMap @'FromClient @t (ClientMessageHandler IO t)
staticHandler = case (forall {f :: From} {t :: MethodType} (a :: Method f t)
       (v :: Method f t -> *).
SMethod @f @t a -> SMethodMap @f @t v -> Maybe (v a)
SMethodMap.lookup SClientMethod @t meth
m RegistrationMap t
dynHandlerMap, forall {f :: From} {t :: MethodType} (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 @'FromClient @t (ClientMessageHandler IO t)
staticHandler) of
      (Just (P.Pair RegistrationId @t meth
_ (ClientMessageHandler Handler @'FromClient @t IO meth
h)), Maybe (ClientMessageHandler IO t meth)
_) -> forall a. a -> Maybe a
Just Handler @'FromClient @t IO meth
h
      (Maybe
  (Product
     @(Method 'FromClient t)
     (RegistrationId @t)
     (ClientMessageHandler IO t)
     meth)
Nothing, Just (ClientMessageHandler Handler @'FromClient @t IO meth
h)) -> forall a. a -> Maybe a
Just Handler @'FromClient @t IO meth
h
      (Maybe
  (Product
     @(Method 'FromClient t)
     (RegistrationId @t)
     (ClientMessageHandler IO t)
     meth)
Nothing, Maybe (ClientMessageHandler IO t meth)
Nothing) -> forall a. Maybe a
Nothing

    -- '$/' notifications should/could be ignored by server.
    -- Don't log errors in that case.
    -- See https://microsoft.github.io/language-server-protocol/specifications/specification-current/#-notifications-and-requests.
    reportMissingHandler :: m ()
    reportMissingHandler :: m ()
reportMissingHandler =
      let optional :: Bool
optional = forall {f :: From} {t :: MethodType} {m :: Method f t}.
SMethod @f @t m -> Bool
isOptionalNotification SClientMethod @t meth
m
      in LogAction m (WithSeverity LspProcessingLog)
logger forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& forall {t :: MethodType} (m :: Method 'FromClient t).
Bool -> SClientMethod @t m -> LspProcessingLog
MissingHandler Bool
optional SClientMethod @t meth
m forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` if Bool
optional then Severity
Warning else Severity
Error
    isOptionalNotification :: SMethod @f @t m -> Bool
isOptionalNotification (SCustomMethod Text
method)
      | Text
"$/" Text -> Text -> Bool
`T.isPrefixOf` Text
method = Bool
True
    isOptionalNotification SMethod @f @t m
_  = Bool
False

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

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

-- | Default Shutdown handler
shutdownRequestHandler :: Handler IO Shutdown
shutdownRequestHandler :: Handler @'FromClient @'Request IO 'Shutdown
shutdownRequestHandler RequestMessage @'FromClient 'Shutdown
_req Either ResponseError Empty -> IO ()
k = do
  Either ResponseError Empty -> IO ()
k forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right Empty
Empty

handleConfigChange :: (m ~ LspM config) => LogAction m (WithSeverity LspProcessingLog) -> Message WorkspaceDidChangeConfiguration -> m ()
handleConfigChange :: forall (m :: * -> *) config.
((m :: (* -> *)) ~ (LspM config :: (* -> *))) =>
LogAction m (WithSeverity LspProcessingLog)
-> Message
     @'FromClient @'Notification 'WorkspaceDidChangeConfiguration
-> m ()
handleConfigChange LogAction m (WithSeverity LspProcessingLog)
logger Message
  @'FromClient @'Notification 'WorkspaceDidChangeConfiguration
req = do
  config -> Value -> Either Text config
parseConfig <- forall config (m :: * -> *) a.
ReaderT (LanguageContextEnv config) m a -> LspT config m a
LspT forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall config.
LanguageContextEnv config -> config -> Value -> Either Text config
resParseConfig
  let settings :: Value
settings = Message
  @'FromClient @'Notification 'WorkspaceDidChangeConfiguration
req forall s a. s -> Getting a s a -> a
^. forall s a. HasParams s a => Lens' s a
LSP.params forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasSettings s a => Lens' s a
LSP.settings
  Either Text ()
res <- forall config (m :: * -> *) s a.
MonadLsp config m =>
(LanguageContextState config -> TVar s) -> (s -> (a, s)) -> m a
stateState forall config. LanguageContextState config -> TVar config
resConfig forall a b. (a -> b) -> a -> b
$ \config
oldConfig -> case config -> Value -> Either Text config
parseConfig config
oldConfig Value
settings of
    Left Text
err -> (forall a b. a -> Either a b
Left Text
err, config
oldConfig)
    Right !config
newConfig -> (forall a b. b -> Either a b
Right (), config
newConfig)
  case Either Text ()
res of
    Left Text
err -> do
      LogAction m (WithSeverity LspProcessingLog)
logger forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& Value -> Text -> LspProcessingLog
ConfigurationParseError Value
settings Text
err forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` Severity
Error
    Right () -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

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

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

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