{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeInType #-}
-- So we can keep using the old prettyprinter modules (which have a better
-- compatibility range) for now.
{-# OPTIONS_GHC -Wno-deprecations #-}
-- 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.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.Maybe
import Data.Monoid
import Data.Row
import Data.String (fromString)
import Data.Text qualified as T
import Data.Text.Lazy.Encoding qualified as TL
import Data.Text.Prettyprint.Doc
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 System.Exit

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

deriving instance Show LspProcessingLog

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

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

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

-- | Call this to initialize the session
initializeRequestHandler ::
  LogAction IO (WithSeverity LspProcessingLog) ->
  ServerDefinition config ->
  VFS ->
  (FromServerMessage -> IO ()) ->
  TMessage Method_Initialize ->
  IO (Maybe (LanguageContextEnv config))
initializeRequestHandler :: forall config.
LogAction IO (WithSeverity LspProcessingLog)
-> ServerDefinition config
-> VFS
-> (FromServerMessage -> IO ())
-> TMessage @'ClientToServer @'Request 'Method_Initialize
-> IO (Maybe (LanguageContextEnv config))
initializeRequestHandler LogAction IO (WithSeverity LspProcessingLog)
logger ServerDefinition{config
Text
Options
config -> m ()
config -> Value -> Either Text config
a -> (<~>) @(*) m IO
ClientCapabilities -> Handlers m
LanguageContextEnv config
-> TMessage @'ClientToServer @'Request 'Method_Initialize
-> IO (Either ResponseError a)
options :: forall config. ServerDefinition config -> Options
interpretHandler :: ()
staticHandlers :: ()
doInitialize :: ()
onConfigChange :: ()
parseConfig :: forall config.
ServerDefinition config -> config -> Value -> Either Text config
configSection :: forall config. ServerDefinition config -> Text
defaultConfig :: forall config. ServerDefinition config -> config
options :: Options
interpretHandler :: a -> (<~>) @(*) m IO
staticHandlers :: ClientCapabilities -> Handlers m
doInitialize :: LanguageContextEnv config
-> TMessage @'ClientToServer @'Request 'Method_Initialize
-> IO (Either ResponseError a)
onConfigChange :: config -> m ()
parseConfig :: config -> Value -> Either Text config
configSection :: Text
defaultConfig :: config
..} VFS
vfs FromServerMessage -> IO ()
sendFunc TMessage @'ClientToServer @'Request 'Method_Initialize
req = do
  let sendResp :: TResponseMessage @'ClientToServer 'Method_Initialize -> IO ()
sendResp = FromServerMessage -> IO ()
sendFunc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: Method 'ClientToServer 'Request)
       (a :: Method 'ClientToServer 'Request -> *).
a m -> TResponseMessage @'ClientToServer m -> FromServerMessage' a
FromServerRsp SMethod @'ClientToServer @'Request 'Method_Initialize
SMethod_Initialize
      handleErr :: Either ResponseError (LanguageContextEnv config)
-> IO (Maybe (LanguageContextEnv config))
handleErr (Left ResponseError
err) = do
        TResponseMessage @'ClientToServer 'Method_Initialize -> IO ()
sendResp forall a b. (a -> b) -> a -> b
$ forall {f :: MessageDirection} {m :: Method f 'Request}.
LspId @f m -> ResponseError -> TResponseMessage @f m
makeResponseError (TMessage @'ClientToServer @'Request 'Method_Initialize
req forall s a. s -> Getting a s a -> a
^. forall s a. HasId s a => Lens' s a
L.id) ResponseError
err
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
      handleErr (Right LanguageContextEnv config
a) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just LanguageContextEnv config
a
  forall a b c. (a -> b -> c) -> b -> a -> c
flip forall e a. Exception e => IO a -> (e -> IO a) -> IO a
E.catch (forall a. (ResponseError -> IO ()) -> SomeException -> IO (Maybe a)
initializeErrorHandler forall a b. (a -> b) -> a -> b
$ TResponseMessage @'ClientToServer 'Method_Initialize -> IO ()
sendResp forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {f :: MessageDirection} {m :: Method f 'Request}.
LspId @f m -> ResponseError -> TResponseMessage @f m
makeResponseError (TMessage @'ClientToServer @'Request 'Method_Initialize
req forall s a. s -> Getting a s a -> a
^. forall s a. HasId s a => Lens' s a
L.id)) forall a b. (a -> b) -> a -> b
$ Either ResponseError (LanguageContextEnv config)
-> IO (Maybe (LanguageContextEnv config))
handleErr forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ mdo
    let p :: InitializeParams
p = TMessage @'ClientToServer @'Request 'Method_Initialize
req forall s a. s -> Getting a s a -> a
^. forall s a. HasParams s a => Lens' s a
L.params
        rootDir :: Maybe String
rootDir =
          forall a. First a -> Maybe a
getFirst forall a b. (a -> b) -> a -> b
$
            forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
              forall a. Maybe a -> First a
First
              [ InitializeParams
p forall s a. s -> Getting (First a) s a -> Maybe a
^? forall s a. HasRootUri s a => Lens' s a
L.rootUri forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism' (a |? b) a
_L forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Uri -> Maybe String
uriToFilePath
              , InitializeParams
p forall s a. s -> Getting (First a) s a -> Maybe a
^? forall s a. HasRootPath s a => Lens' s a
L.rootPath forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism' (a |? b) a
_L forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Text -> String
T.unpack
              ]
        clientCaps :: ClientCapabilities
clientCaps = (InitializeParams
p forall s a. s -> Getting a s a -> a
^. forall s a. HasCapabilities s a => Lens' s a
L.capabilities)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

  diagnosticProvider :: Maybe (DiagnosticOptions |? b)
diagnosticProvider =
    forall {t :: MessageKind} {m :: Method 'ClientToServer t} {a}.
SClientMethod @t m -> a -> Maybe a
supported' SMethod @'ClientToServer @'Request 'Method_TextDocumentDiagnostic
SMethod_TextDocumentDiagnostic forall a b. (a -> b) -> a -> b
$
      forall a b. a -> a |? b
InL forall a b. (a -> b) -> a -> b
$
        DiagnosticOptions
          { $sel:_workDoneProgress:DiagnosticOptions :: Maybe Bool
_workDoneProgress = forall a. Maybe a
Nothing
          , $sel:_identifier:DiagnosticOptions :: Maybe Text
_identifier = forall a. Maybe a
Nothing
          , -- TODO: this is a conservative but maybe inaccurate, unclear how much it matters
            $sel:_interFileDependencies:DiagnosticOptions :: Bool
_interFileDependencies = Bool
True
          , $sel:_workspaceDiagnostics:DiagnosticOptions :: Bool
_workspaceDiagnostics = forall {t :: MessageKind} (m :: Method 'ClientToServer t).
SClientMethod @t m -> Bool
supported_b SMethod @'ClientToServer @'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 :: (m ~ LspM config) => LogAction m (WithSeverity LspProcessingLog) -> SClientMethod meth -> TClientMessage meth -> m ()
handle :: forall {t :: MessageKind} (m :: * -> *) config
       (meth :: Method 'ClientToServer t).
((m :: (* -> *)) ~ (LspM config :: (* -> *))) =>
LogAction m (WithSeverity LspProcessingLog)
-> SClientMethod @t meth -> TClientMessage @t meth -> m ()
handle LogAction m (WithSeverity LspProcessingLog)
logger SClientMethod @t meth
m TClientMessage @t meth
msg =
  case SClientMethod @t meth
m of
    SClientMethod @t meth
SMethod_WorkspaceDidChangeWorkspaceFolders -> forall (m :: * -> *) (t :: MessageKind)
       (meth :: Method 'ClientToServer t) config.
((m :: (* -> *)) ~ (LspM config :: (* -> *))) =>
LogAction m (WithSeverity LspProcessingLog)
-> Maybe (TClientMessage @t meth -> m ())
-> SClientMethod @t meth
-> TClientMessage @t meth
-> m ()
handle' LogAction m (WithSeverity LspProcessingLog)
logger (forall a. a -> Maybe a
Just forall config.
TMessage
  @'ClientToServer
  @'Notification
  'Method_WorkspaceDidChangeWorkspaceFolders
-> LspM config ()
updateWorkspaceFolders) SClientMethod @t meth
m TClientMessage @t meth
msg
    SClientMethod @t meth
SMethod_WorkspaceDidChangeConfiguration -> forall (m :: * -> *) (t :: MessageKind)
       (meth :: Method 'ClientToServer t) config.
((m :: (* -> *)) ~ (LspM config :: (* -> *))) =>
LogAction m (WithSeverity LspProcessingLog)
-> Maybe (TClientMessage @t meth -> m ())
-> SClientMethod @t meth
-> TClientMessage @t meth
-> m ()
handle' LogAction m (WithSeverity LspProcessingLog)
logger (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) config.
((m :: (* -> *)) ~ (LspM config :: (* -> *))) =>
LogAction m (WithSeverity LspProcessingLog)
-> TMessage
     @'ClientToServer
     @'Notification
     'Method_WorkspaceDidChangeConfiguration
-> m ()
handleDidChangeConfiguration LogAction m (WithSeverity LspProcessingLog)
logger) SClientMethod @t meth
m TClientMessage @t meth
msg
    -- See Note [LSP configuration]
    SClientMethod @t meth
SMethod_Initialized -> forall (m :: * -> *) (t :: MessageKind)
       (meth :: Method 'ClientToServer t) config.
((m :: (* -> *)) ~ (LspM config :: (* -> *))) =>
LogAction m (WithSeverity LspProcessingLog)
-> Maybe (TClientMessage @t meth -> m ())
-> SClientMethod @t meth
-> TClientMessage @t meth
-> m ()
handle' LogAction m (WithSeverity LspProcessingLog)
logger (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ \TClientMessage @t meth
_ -> forall (m :: * -> *) config.
((m :: (* -> *)) ~ (LspM config :: (* -> *))) =>
LogAction m (WithSeverity LspCoreLog) -> m ()
requestConfigUpdate (forall a b (m :: * -> *).
(a -> b) -> LogAction m b -> LogAction m a
cmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LspCoreLog -> LspProcessingLog
LspCore) LogAction m (WithSeverity LspProcessingLog)
logger)) SClientMethod @t meth
m TClientMessage @t meth
msg
    SClientMethod @t meth
SMethod_TextDocumentDidOpen -> forall (m :: * -> *) (t :: MessageKind)
       (meth :: Method 'ClientToServer t) config.
((m :: (* -> *)) ~ (LspM config :: (* -> *))) =>
LogAction m (WithSeverity LspProcessingLog)
-> Maybe (TClientMessage @t meth -> m ())
-> SClientMethod @t meth
-> TClientMessage @t meth
-> m ()
handle' LogAction m (WithSeverity LspProcessingLog)
logger (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (n :: * -> *) a config.
((m :: (* -> *)) ~ (LspM config :: (* -> *)),
 (n :: (* -> *))
 ~ (WriterT [WithSeverity VfsLog] (State VFS) :: (* -> *))) =>
LogAction m (WithSeverity LspProcessingLog)
-> (LogAction n (WithSeverity VfsLog) -> a -> n ()) -> a -> m ()
vfsFunc LogAction m (WithSeverity LspProcessingLog)
logger forall (m :: * -> *).
MonadState VFS m =>
LogAction m (WithSeverity VfsLog)
-> TMessage
     @'ClientToServer @'Notification 'Method_TextDocumentDidOpen
-> m ()
openVFS) SClientMethod @t meth
m TClientMessage @t meth
msg
    SClientMethod @t meth
SMethod_TextDocumentDidChange -> forall (m :: * -> *) (t :: MessageKind)
       (meth :: Method 'ClientToServer t) config.
((m :: (* -> *)) ~ (LspM config :: (* -> *))) =>
LogAction m (WithSeverity LspProcessingLog)
-> Maybe (TClientMessage @t meth -> m ())
-> SClientMethod @t meth
-> TClientMessage @t meth
-> m ()
handle' LogAction m (WithSeverity LspProcessingLog)
logger (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (n :: * -> *) a config.
((m :: (* -> *)) ~ (LspM config :: (* -> *)),
 (n :: (* -> *))
 ~ (WriterT [WithSeverity VfsLog] (State VFS) :: (* -> *))) =>
LogAction m (WithSeverity LspProcessingLog)
-> (LogAction n (WithSeverity VfsLog) -> a -> n ()) -> a -> m ()
vfsFunc LogAction m (WithSeverity LspProcessingLog)
logger forall (m :: * -> *).
MonadState VFS m =>
LogAction m (WithSeverity VfsLog)
-> TMessage
     @'ClientToServer @'Notification 'Method_TextDocumentDidChange
-> m ()
changeFromClientVFS) SClientMethod @t meth
m TClientMessage @t meth
msg
    SClientMethod @t meth
SMethod_TextDocumentDidClose -> forall (m :: * -> *) (t :: MessageKind)
       (meth :: Method 'ClientToServer t) config.
((m :: (* -> *)) ~ (LspM config :: (* -> *))) =>
LogAction m (WithSeverity LspProcessingLog)
-> Maybe (TClientMessage @t meth -> m ())
-> SClientMethod @t meth
-> TClientMessage @t meth
-> m ()
handle' LogAction m (WithSeverity LspProcessingLog)
logger (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (n :: * -> *) a config.
((m :: (* -> *)) ~ (LspM config :: (* -> *)),
 (n :: (* -> *))
 ~ (WriterT [WithSeverity VfsLog] (State VFS) :: (* -> *))) =>
LogAction m (WithSeverity LspProcessingLog)
-> (LogAction n (WithSeverity VfsLog) -> a -> n ()) -> a -> m ()
vfsFunc LogAction m (WithSeverity LspProcessingLog)
logger forall (m :: * -> *).
MonadState VFS m =>
LogAction m (WithSeverity VfsLog)
-> TMessage
     @'ClientToServer @'Notification 'Method_TextDocumentDidClose
-> m ()
closeVFS) SClientMethod @t meth
m TClientMessage @t meth
msg
    SClientMethod @t meth
SMethod_WindowWorkDoneProgressCancel -> forall (m :: * -> *) (t :: MessageKind)
       (meth :: Method 'ClientToServer t) config.
((m :: (* -> *)) ~ (LspM config :: (* -> *))) =>
LogAction m (WithSeverity LspProcessingLog)
-> Maybe (TClientMessage @t meth -> m ())
-> SClientMethod @t meth
-> TClientMessage @t meth
-> m ()
handle' LogAction m (WithSeverity LspProcessingLog)
logger (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) config.
((m :: (* -> *)) ~ (LspM config :: (* -> *))) =>
LogAction m (WithSeverity LspProcessingLog)
-> TMessage
     @'ClientToServer
     @'Notification
     'Method_WindowWorkDoneProgressCancel
-> m ()
progressCancelHandler LogAction m (WithSeverity LspProcessingLog)
logger) SClientMethod @t meth
m TClientMessage @t meth
msg
    SClientMethod @t meth
_ -> forall (m :: * -> *) (t :: MessageKind)
       (meth :: Method 'ClientToServer t) config.
((m :: (* -> *)) ~ (LspM config :: (* -> *))) =>
LogAction m (WithSeverity LspProcessingLog)
-> Maybe (TClientMessage @t meth -> m ())
-> SClientMethod @t meth
-> TClientMessage @t meth
-> m ()
handle' LogAction m (WithSeverity LspProcessingLog)
logger forall a. Maybe a
Nothing SClientMethod @t meth
m TClientMessage @t meth
msg

handle' ::
  forall m t (meth :: Method ClientToServer t) config.
  (m ~ LspM config) =>
  LogAction m (WithSeverity LspProcessingLog) ->
  -- | 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
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) (\TClientMessage @t meth -> m ()
f -> TClientMessage @t meth -> m ()
f TClientMessage @t meth
msg) Maybe (TClientMessage @t meth -> m ())
mAction

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

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

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

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

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

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

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

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

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

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

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

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

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

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