{-# 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 :: LspProcessingLog -> Doc ann
pretty (VfsLog VfsLog
l) = VfsLog -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty VfsLog
l
  pretty (MessageProcessingError ByteString
bs String
err) =
    [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep [
      Doc ann
"LSP: incoming message parse error:"
      , String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
err
      , Doc ann
"when processing"
      , Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (ByteString -> Text
TL.decodeUtf8 ByteString
bs)
      ]
  pretty (MissingHandler Bool
_ SClientMethod @t m
m) = Doc ann
"LSP: no handler for:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> SClientMethod @t m -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow SClientMethod @t m
m
  pretty (ConfigurationParseError Value
settings Text
err) =
    [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep [
      Doc ann
"LSP: configuration parse error:"
      , Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
err
      , Doc ann
"when parsing"
      , Value -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow Value
settings
      ]
  pretty (ProgressCancel ProgressToken
tid) = Doc ann
"LSP: cancelling action for token:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ProgressToken -> Doc ann
forall a ann. 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 :: LogAction m (WithSeverity LspProcessingLog) -> ByteString -> m ()
processMessage LogAction m (WithSeverity LspProcessingLog)
logger ByteString
jsonStr = do
  TVar ResponseMap
pendingResponsesVar <- ReaderT (LanguageContextEnv config) IO (TVar ResponseMap)
-> LspT config IO (TVar ResponseMap)
forall config (m :: * -> *) a.
ReaderT (LanguageContextEnv config) m a -> LspT config m a
LspT (ReaderT (LanguageContextEnv config) IO (TVar ResponseMap)
 -> LspT config IO (TVar ResponseMap))
-> ReaderT (LanguageContextEnv config) IO (TVar ResponseMap)
-> LspT config IO (TVar ResponseMap)
forall a b. (a -> b) -> a -> b
$ (LanguageContextEnv config -> TVar ResponseMap)
-> ReaderT (LanguageContextEnv config) IO (TVar ResponseMap)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((LanguageContextEnv config -> TVar ResponseMap)
 -> ReaderT (LanguageContextEnv config) IO (TVar ResponseMap))
-> (LanguageContextEnv config -> TVar ResponseMap)
-> ReaderT (LanguageContextEnv config) IO (TVar ResponseMap)
forall a b. (a -> b) -> a -> b
$ LanguageContextState config -> TVar ResponseMap
forall config. LanguageContextState config -> TVar ResponseMap
resPendingResponses (LanguageContextState config -> TVar ResponseMap)
-> (LanguageContextEnv config -> LanguageContextState config)
-> LanguageContextEnv config
-> TVar ResponseMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LanguageContextEnv config -> LanguageContextState config
forall config.
LanguageContextEnv config -> LanguageContextState config
resState
  m (m ()) -> m ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (m (m ()) -> m ()) -> m (m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ IO (m ()) -> m (m ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (m ()) -> m (m ())) -> IO (m ()) -> m (m ())
forall a b. (a -> b) -> a -> b
$ STM (m ()) -> IO (m ())
forall a. STM a -> IO a
atomically (STM (m ()) -> IO (m ())) -> STM (m ()) -> IO (m ())
forall a b. (a -> b) -> a -> b
$ (Either String (m ()) -> m ())
-> STM (Either String (m ())) -> STM (m ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either String (m ()) -> m ()
handleErrors (STM (Either String (m ())) -> STM (m ()))
-> STM (Either String (m ())) -> STM (m ())
forall a b. (a -> b) -> a -> b
$ ExceptT String STM (m ()) -> STM (Either String (m ()))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT String STM (m ()) -> STM (Either String (m ())))
-> ExceptT String STM (m ()) -> STM (Either String (m ()))
forall a b. (a -> b) -> a -> b
$ do
      Value
val <- Either String Value -> ExceptT String STM Value
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either String Value -> ExceptT String STM Value)
-> Either String Value -> ExceptT String STM Value
forall a b. (a -> b) -> a -> b
$ ByteString -> Either String Value
forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
jsonStr
      ResponseMap
pending <- STM ResponseMap -> ExceptT String STM ResponseMap
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (STM ResponseMap -> ExceptT String STM ResponseMap)
-> STM ResponseMap -> ExceptT String STM ResponseMap
forall a b. (a -> b) -> a -> b
$ TVar ResponseMap -> STM ResponseMap
forall a. TVar a -> STM a
readTVar TVar ResponseMap
pendingResponsesVar
      FromClientMessage'
  (Product
     @(Method 'FromServer 'Request)
     ServerResponseCallback
     (Const @(Method 'FromServer 'Request) ResponseMap))
msg <- Either
  String
  (FromClientMessage'
     (Product
        @(Method 'FromServer 'Request)
        ServerResponseCallback
        (Const @(Method 'FromServer 'Request) ResponseMap)))
-> ExceptT
     String
     STM
     (FromClientMessage'
        (Product
           @(Method 'FromServer 'Request)
           ServerResponseCallback
           (Const @(Method 'FromServer 'Request) ResponseMap)))
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either
   String
   (FromClientMessage'
      (Product
         @(Method 'FromServer 'Request)
         ServerResponseCallback
         (Const @(Method 'FromServer 'Request) ResponseMap)))
 -> ExceptT
      String
      STM
      (FromClientMessage'
         (Product
            @(Method 'FromServer 'Request)
            ServerResponseCallback
            (Const @(Method 'FromServer 'Request) ResponseMap))))
-> Either
     String
     (FromClientMessage'
        (Product
           @(Method 'FromServer 'Request)
           ServerResponseCallback
           (Const @(Method 'FromServer 'Request) ResponseMap)))
-> ExceptT
     String
     STM
     (FromClientMessage'
        (Product
           @(Method 'FromServer 'Request)
           ServerResponseCallback
           (Const @(Method 'FromServer 'Request) ResponseMap)))
forall a b. (a -> b) -> a -> b
$ (Value
 -> Parser
      (FromClientMessage'
         (Product
            @(Method 'FromServer 'Request)
            ServerResponseCallback
            (Const @(Method 'FromServer 'Request) ResponseMap))))
-> Value
-> Either
     String
     (FromClientMessage'
        (Product
           @(Method 'FromServer 'Request)
           ServerResponseCallback
           (Const @(Method 'FromServer 'Request) ResponseMap)))
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
      STM (m ()) -> ExceptT String STM (m ())
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (STM (m ()) -> ExceptT String STM (m ()))
-> STM (m ()) -> ExceptT String STM (m ())
forall a b. (a -> b) -> a -> b
$ case FromClientMessage'
  (Product
     @(Method 'FromServer 'Request)
     ServerResponseCallback
     (Const @(Method 'FromServer 'Request) ResponseMap))
msg of
        FromClientMess SMethod @'FromClient @t m
m Message @'FromClient @t m
mess ->
          m () -> STM (m ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (m () -> STM (m ())) -> m () -> STM (m ())
forall a b. (a -> b) -> a -> b
$ LogAction m (WithSeverity LspProcessingLog)
-> SMethod @'FromClient @t m -> Message @'FromClient @t m -> m ()
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
          TVar ResponseMap -> ResponseMap -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar ResponseMap
pendingResponsesVar ResponseMap
newMap
          LspT config IO () -> STM (LspT config IO ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LspT config IO () -> STM (LspT config IO ()))
-> LspT config IO () -> STM (LspT config IO ())
forall a b. (a -> b) -> a -> b
$ IO () -> LspT config IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> LspT config IO ()) -> IO () -> LspT config IO ()
forall a b. (a -> b) -> a -> b
$ Either ResponseError (ResponseResult @'FromServer m) -> IO ()
f (ResponseMessage @'FromServer m
res ResponseMessage @'FromServer m
-> Getting
     (Either ResponseError (ResponseResult @'FromServer m))
     (ResponseMessage @'FromServer m)
     (Either ResponseError (ResponseResult @'FromServer m))
-> Either ResponseError (ResponseResult @'FromServer m)
forall s a. s -> Getting a s a -> a
^. Getting
  (Either ResponseError (ResponseResult @'FromServer m))
  (ResponseMessage @'FromServer m)
  (Either ResponseError (ResponseResult @'FromServer m))
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 = LookupFunc
  'FromServer
  (Product
     @(Method 'FromServer 'Request)
     ServerResponseCallback
     (Const @(Method 'FromServer 'Request) ResponseMap))
-> Value
-> Parser
     (FromClientMessage'
        (Product
           @(Method 'FromServer 'Request)
           ServerResponseCallback
           (Const @(Method 'FromServer 'Request) ResponseMap)))
forall (a :: Method 'FromServer 'Request -> *).
LookupFunc 'FromServer a -> Value -> Parser (FromClientMessage' a)
parseClientMessage (LookupFunc
   'FromServer
   (Product
      @(Method 'FromServer 'Request)
      ServerResponseCallback
      (Const @(Method 'FromServer 'Request) ResponseMap))
 -> Value
 -> Parser
      (FromClientMessage'
         (Product
            @(Method 'FromServer 'Request)
            ServerResponseCallback
            (Const @(Method 'FromServer 'Request) ResponseMap))))
-> LookupFunc
     'FromServer
     (Product
        @(Method 'FromServer 'Request)
        ServerResponseCallback
        (Const @(Method 'FromServer 'Request) ResponseMap))
-> Value
-> Parser
     (FromClientMessage'
        (Product
           @(Method 'FromServer 'Request)
           ServerResponseCallback
           (Const @(Method 'FromServer 'Request) ResponseMap)))
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) = LspId @'FromServer m
-> ResponseMap
-> (Maybe
      (Product
         @(Method 'FromServer 'Request)
         (SMethod @'FromServer @'Request)
         ServerResponseCallback
         m),
    ResponseMap)
forall a (k :: a -> *) (m :: a) (f :: a -> *).
IxOrd @a k =>
k m -> IxMap @a k f -> (Maybe (f m), IxMap @a k f)
pickFromIxMap LspId @'FromServer m
i ResponseMap
rm
        in (\(P.Pair SMethod @'FromServer @'Request m
m ServerResponseCallback m
handler) -> (SMethod @'FromServer @'Request m
m,ServerResponseCallback m
-> Const @(Method 'FromServer 'Request) ResponseMap m
-> Product
     @(Method 'FromServer 'Request)
     ServerResponseCallback
     (Const @(Method 'FromServer 'Request) ResponseMap)
     m
forall k (f :: k -> *) (g :: k -> *) (a :: k).
f a -> g a -> Product @k f g a
P.Pair ServerResponseCallback m
handler (ResponseMap -> Const @(Method 'FromServer 'Request) ResponseMap m
forall k a (b :: k). a -> Const @k a b
Const ResponseMap
newMap))) (Product
   @(Method 'FromServer 'Request)
   (SMethod @'FromServer @'Request)
   ServerResponseCallback
   m
 -> (SMethod @'FromServer @'Request m,
     Product
       @(Method 'FromServer 'Request)
       ServerResponseCallback
       (Const @(Method 'FromServer 'Request) ResponseMap)
       m))
-> Maybe
     (Product
        @(Method 'FromServer 'Request)
        (SMethod @'FromServer @'Request)
        ServerResponseCallback
        m)
-> Maybe
     (SMethod @'FromServer @'Request m,
      Product
        @(Method 'FromServer 'Request)
        ServerResponseCallback
        (Const @(Method 'FromServer 'Request) ResponseMap)
        m)
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 = (String -> m ()) -> (m () -> m ()) -> Either String (m ()) -> m ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\String
e -> LogAction m (WithSeverity LspProcessingLog)
logger LogAction m (WithSeverity LspProcessingLog)
-> WithSeverity LspProcessingLog -> m ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& ByteString -> String -> LspProcessingLog
MessageProcessingError ByteString
jsonStr String
e LspProcessingLog -> Severity -> WithSeverity LspProcessingLog
forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` Severity
Error) m () -> m ()
forall a. a -> a
id

-- | Call this to initialize the session
initializeRequestHandler
  :: ServerDefinition config
  -> VFS
  -> (FromServerMessage -> IO ())
  -> Message Initialize
  -> IO (Maybe (LanguageContextEnv config))
initializeRequestHandler :: 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 (FromServerMessage -> IO ())
-> (ResponseMessage @'FromClient 'Initialize -> FromServerMessage)
-> ResponseMessage @'FromClient 'Initialize
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SMethod @'FromClient @'Request 'Initialize
-> ResponseMessage @'FromClient 'Initialize -> FromServerMessage
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 (ResponseMessage @'FromClient 'Initialize -> IO ())
-> ResponseMessage @'FromClient 'Initialize -> IO ()
forall a b. (a -> b) -> a -> b
$ LspId @'FromClient 'Initialize
-> ResponseError -> ResponseMessage @'FromClient 'Initialize
forall (f :: From) (m :: Method f 'Request).
LspId @f m -> ResponseError -> ResponseMessage @f m
makeResponseError (Message @'FromClient @'Request 'Initialize
RequestMessage @'FromClient 'Initialize
req RequestMessage @'FromClient 'Initialize
-> Getting
     (LspId @'FromClient 'Initialize)
     (RequestMessage @'FromClient 'Initialize)
     (LspId @'FromClient 'Initialize)
-> LspId @'FromClient 'Initialize
forall s a. s -> Getting a s a -> a
^. Getting
  (LspId @'FromClient 'Initialize)
  (RequestMessage @'FromClient 'Initialize)
  (LspId @'FromClient 'Initialize)
forall s a. HasId s a => Lens' s a
LSP.id) ResponseError
err
        Maybe (LanguageContextEnv config)
-> IO (Maybe (LanguageContextEnv config))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (LanguageContextEnv config)
forall a. Maybe a
Nothing
      handleErr (Right LanguageContextEnv config
a) = Maybe (LanguageContextEnv config)
-> IO (Maybe (LanguageContextEnv config))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (LanguageContextEnv config)
 -> IO (Maybe (LanguageContextEnv config)))
-> Maybe (LanguageContextEnv config)
-> IO (Maybe (LanguageContextEnv config))
forall a b. (a -> b) -> a -> b
$ LanguageContextEnv config -> Maybe (LanguageContextEnv config)
forall a. a -> Maybe a
Just LanguageContextEnv config
a
  (IO (Maybe (LanguageContextEnv config))
 -> (SomeException -> IO (Maybe (LanguageContextEnv config)))
 -> IO (Maybe (LanguageContextEnv config)))
-> (SomeException -> IO (Maybe (LanguageContextEnv config)))
-> IO (Maybe (LanguageContextEnv config))
-> IO (Maybe (LanguageContextEnv config))
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO (Maybe (LanguageContextEnv config))
-> (SomeException -> IO (Maybe (LanguageContextEnv config)))
-> IO (Maybe (LanguageContextEnv config))
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
E.catch ((ResponseError -> IO ())
-> SomeException -> IO (Maybe (LanguageContextEnv config))
forall a. (ResponseError -> IO ()) -> SomeException -> IO (Maybe a)
initializeErrorHandler ((ResponseError -> IO ())
 -> SomeException -> IO (Maybe (LanguageContextEnv config)))
-> (ResponseError -> IO ())
-> SomeException
-> IO (Maybe (LanguageContextEnv config))
forall a b. (a -> b) -> a -> b
$ ResponseMessage @'FromClient 'Initialize -> IO ()
sendResp (ResponseMessage @'FromClient 'Initialize -> IO ())
-> (ResponseError -> ResponseMessage @'FromClient 'Initialize)
-> ResponseError
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LspId @'FromClient 'Initialize
-> ResponseError -> ResponseMessage @'FromClient 'Initialize
forall (f :: From) (m :: Method f 'Request).
LspId @f m -> ResponseError -> ResponseMessage @f m
makeResponseError (Message @'FromClient @'Request 'Initialize
RequestMessage @'FromClient 'Initialize
req RequestMessage @'FromClient 'Initialize
-> Getting
     (LspId @'FromClient 'Initialize)
     (RequestMessage @'FromClient 'Initialize)
     (LspId @'FromClient 'Initialize)
-> LspId @'FromClient 'Initialize
forall s a. s -> Getting a s a -> a
^. Getting
  (LspId @'FromClient 'Initialize)
  (RequestMessage @'FromClient 'Initialize)
  (LspId @'FromClient 'Initialize)
forall s a. HasId s a => Lens' s a
LSP.id)) (IO (Maybe (LanguageContextEnv config))
 -> IO (Maybe (LanguageContextEnv config)))
-> IO (Maybe (LanguageContextEnv config))
-> IO (Maybe (LanguageContextEnv config))
forall a b. (a -> b) -> a -> b
$ Either ResponseError (LanguageContextEnv config)
-> IO (Maybe (LanguageContextEnv config))
handleErr (Either ResponseError (LanguageContextEnv config)
 -> IO (Maybe (LanguageContextEnv config)))
-> (ExceptT ResponseError IO (LanguageContextEnv config)
    -> IO (Either ResponseError (LanguageContextEnv config)))
-> ExceptT ResponseError IO (LanguageContextEnv config)
-> IO (Maybe (LanguageContextEnv config))
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< ExceptT ResponseError IO (LanguageContextEnv config)
-> IO (Either ResponseError (LanguageContextEnv config))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT ResponseError IO (LanguageContextEnv config)
 -> IO (Maybe (LanguageContextEnv config)))
-> ExceptT ResponseError IO (LanguageContextEnv config)
-> IO (Maybe (LanguageContextEnv config))
forall a b. (a -> b) -> a -> b
$ mdo

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

    let initialWfs :: [WorkspaceFolder]
initialWfs = case InitializeParams
params InitializeParams
-> Getting
     (Maybe (List WorkspaceFolder))
     InitializeParams
     (Maybe (List WorkspaceFolder))
-> Maybe (List WorkspaceFolder)
forall s a. s -> Getting a s a -> a
^. Getting
  (Maybe (List WorkspaceFolder))
  InitializeParams
  (Maybe (List WorkspaceFolder))
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 (Value -> Either Text config)
-> Maybe Value -> Maybe (Either Text config)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Message @'FromClient @'Request 'Initialize
RequestMessage @'FromClient 'Initialize
req RequestMessage @'FromClient 'Initialize
-> Getting
     (Maybe Value)
     (RequestMessage @'FromClient 'Initialize)
     (Maybe Value)
-> Maybe Value
forall s a. s -> Getting a s a -> a
^. (InitializeParams -> Const @* (Maybe Value) InitializeParams)
-> RequestMessage @'FromClient 'Initialize
-> Const @* (Maybe Value) (RequestMessage @'FromClient 'Initialize)
forall s a. HasParams s a => Lens' s a
LSP.params ((InitializeParams -> Const @* (Maybe Value) InitializeParams)
 -> RequestMessage @'FromClient 'Initialize
 -> Const
      @* (Maybe Value) (RequestMessage @'FromClient 'Initialize))
-> ((Maybe Value -> Const @* (Maybe Value) (Maybe Value))
    -> InitializeParams -> Const @* (Maybe Value) InitializeParams)
-> Getting
     (Maybe Value)
     (RequestMessage @'FromClient 'Initialize)
     (Maybe Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Value -> Const @* (Maybe Value) (Maybe Value))
-> InitializeParams -> Const @* (Maybe Value) InitializeParams
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 <- IO (LanguageContextState config)
-> ExceptT ResponseError IO (LanguageContextState config)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (LanguageContextState config)
 -> ExceptT ResponseError IO (LanguageContextState config))
-> IO (LanguageContextState config)
-> ExceptT ResponseError IO (LanguageContextState config)
forall a b. (a -> b) -> a -> b
$ do
      TVar VFSData
resVFS              <- VFSData -> IO (TVar VFSData)
forall a. a -> IO (TVar a)
newTVarIO (VFS -> Map String String -> VFSData
VFSData VFS
vfs Map String String
forall a. Monoid a => a
mempty)
      TVar DiagnosticStore
resDiagnostics      <- DiagnosticStore -> IO (TVar DiagnosticStore)
forall a. a -> IO (TVar a)
newTVarIO DiagnosticStore
forall a. Monoid a => a
mempty
      TVar config
resConfig           <- config -> IO (TVar config)
forall a. a -> IO (TVar a)
newTVarIO config
initialConfig
      TVar [WorkspaceFolder]
resWorkspaceFolders <- [WorkspaceFolder] -> IO (TVar [WorkspaceFolder])
forall a. a -> IO (TVar a)
newTVarIO [WorkspaceFolder]
initialWfs
      ProgressData
resProgressData     <- do
        TVar Int32
progressNextId <- Int32 -> IO (TVar Int32)
forall a. a -> IO (TVar a)
newTVarIO Int32
0
        TVar (Map ProgressToken (IO ()))
progressCancel <- Map ProgressToken (IO ()) -> IO (TVar (Map ProgressToken (IO ())))
forall a. a -> IO (TVar a)
newTVarIO Map ProgressToken (IO ())
forall a. Monoid a => a
mempty
        ProgressData -> IO ProgressData
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProgressData :: TVar Int32 -> TVar (Map ProgressToken (IO ())) -> ProgressData
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 <- ResponseMap -> IO (TVar ResponseMap)
forall a. a -> IO (TVar a)
newTVarIO ResponseMap
forall a (k :: a -> *) (f :: a -> *). IxMap @a k f
emptyIxMap
      TVar (RegistrationMap 'Notification)
resRegistrationsNot <- RegistrationMap 'Notification
-> IO (TVar (RegistrationMap 'Notification))
forall a. a -> IO (TVar a)
newTVarIO RegistrationMap 'Notification
forall a. Monoid a => a
mempty
      TVar (RegistrationMap 'Request)
resRegistrationsReq <- RegistrationMap 'Request -> IO (TVar (RegistrationMap 'Request))
forall a. a -> IO (TVar a)
newTVarIO RegistrationMap 'Request
forall a. Monoid a => a
mempty
      TVar Int32
resLspId            <- Int32 -> IO (TVar Int32)
forall a. a -> IO (TVar a)
newTVarIO Int32
0
      LanguageContextState config -> IO (LanguageContextState config)
forall (f :: * -> *) a. Applicative f => a -> f a
pure LanguageContextState :: forall config.
TVar VFSData
-> TVar DiagnosticStore
-> TVar config
-> TVar [WorkspaceFolder]
-> ProgressData
-> TVar ResponseMap
-> TVar (RegistrationMap 'Notification)
-> TVar (RegistrationMap 'Request)
-> TVar Int32
-> LanguageContextState config
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 = Handlers IO
-> (config -> Value -> Either Text config)
-> (FromServerMessage -> IO ())
-> LanguageContextState config
-> ClientCapabilities
-> Maybe String
-> LanguageContextEnv config
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 InitializeParams
-> Getting ClientCapabilities InitializeParams ClientCapabilities
-> ClientCapabilities
forall s a. s -> Getting a s a -> a
^. Getting ClientCapabilities InitializeParams ClientCapabilities
forall s a. HasCapabilities s a => Lens' s a
LSP.capabilities) Maybe String
rootDir
        handlers :: Handlers IO
handlers = (<~>) @* m IO -> Handlers m -> Handlers IO
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 <- IO (Either ResponseError a) -> ExceptT ResponseError IO a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either ResponseError a) -> ExceptT ResponseError IO a)
-> IO (Either ResponseError a) -> ExceptT ResponseError IO a
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 = ClientCapabilities -> Options -> Handlers IO -> ServerCapabilities
forall (m :: * -> *).
ClientCapabilities -> Options -> Handlers m -> ServerCapabilities
inferServerCapabilities (InitializeParams
params InitializeParams
-> Getting ClientCapabilities InitializeParams ClientCapabilities
-> ClientCapabilities
forall s a. s -> Getting a s a -> a
^. Getting ClientCapabilities InitializeParams ClientCapabilities
forall s a. HasCapabilities s a => Lens' s a
LSP.capabilities) Options
options Handlers IO
handlers
    IO () -> ExceptT ResponseError IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT ResponseError IO ())
-> IO () -> ExceptT ResponseError IO ()
forall a b. (a -> b) -> a -> b
$ ResponseMessage @'FromClient 'Initialize -> IO ()
sendResp (ResponseMessage @'FromClient 'Initialize -> IO ())
-> ResponseMessage @'FromClient 'Initialize -> IO ()
forall a b. (a -> b) -> a -> b
$ LspId @'FromClient 'Initialize
-> ResponseResult @'FromClient 'Initialize
-> ResponseMessage @'FromClient 'Initialize
forall (f :: From) (m :: Method f 'Request).
LspId @f m -> ResponseResult @f m -> ResponseMessage @f m
makeResponseMessage (Message @'FromClient @'Request 'Initialize
RequestMessage @'FromClient 'Initialize
req RequestMessage @'FromClient 'Initialize
-> Getting
     (LspId @'FromClient 'Initialize)
     (RequestMessage @'FromClient 'Initialize)
     (LspId @'FromClient 'Initialize)
-> LspId @'FromClient 'Initialize
forall s a. s -> Getting a s a -> a
^. Getting
  (LspId @'FromClient 'Initialize)
  (RequestMessage @'FromClient 'Initialize)
  (LspId @'FromClient 'Initialize)
forall s a. HasId s a => Lens' s a
LSP.id) (ServerCapabilities -> Maybe ServerInfo -> InitializeResult
InitializeResult ServerCapabilities
serverCaps (Options -> Maybe ServerInfo
serverInfo Options
options))
    LanguageContextEnv config
-> ExceptT ResponseError IO (LanguageContextEnv config)
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 = Text
-> Maybe (LspId @f m)
-> Either ResponseError (ResponseResult @f m)
-> ResponseMessage @f m
forall (f :: From) (m :: Method f 'Request).
Text
-> Maybe (LspId @f m)
-> Either ResponseError (ResponseResult @f m)
-> ResponseMessage @f m
ResponseMessage Text
"2.0" (LspId @f m -> Maybe (LspId @f m)
forall a. a -> Maybe a
Just LspId @f m
rid) (ResponseResult @f m -> Either ResponseError (ResponseResult @f m)
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 = Text
-> Maybe (LspId @f m)
-> Either ResponseError (ResponseResult @f m)
-> ResponseMessage @f m
forall (f :: From) (m :: Method f 'Request).
Text
-> Maybe (LspId @f m)
-> Either ResponseError (ResponseResult @f m)
-> ResponseMessage @f m
ResponseMessage Text
"2.0" (LspId @f m -> Maybe (LspId @f m)
forall a. a -> Maybe a
Just LspId @f m
origId) (ResponseError -> Either ResponseError (ResponseResult @f m)
forall a b. a -> Either a b
Left ResponseError
err)

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


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

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

    supported_b :: forall m. SClientMethod m -> Bool
    supported_b :: SClientMethod @t m -> Bool
supported_b SClientMethod @t m
m = case SClientMethod @t m -> ClientNotOrReq @t m
forall (t :: MethodType) (m :: Method 'FromClient t).
SClientMethod @t m -> ClientNotOrReq @t m
splitClientMethod SClientMethod @t m
m of
      ClientNotOrReq @t m
IsClientNot -> SClientMethod @t m
-> SMethodMap
     @'FromClient @'Notification (ClientMessageHandler m 'Notification)
-> Bool
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 (SMethodMap
   @'FromClient @'Notification (ClientMessageHandler m 'Notification)
 -> Bool)
-> SMethodMap
     @'FromClient @'Notification (ClientMessageHandler m 'Notification)
-> Bool
forall a b. (a -> b) -> a -> b
$ Handlers m
-> SMethodMap
     @'FromClient @'Notification (ClientMessageHandler m 'Notification)
forall (m :: * -> *).
Handlers m
-> SMethodMap
     @'FromClient @'Notification (ClientMessageHandler m 'Notification)
notHandlers Handlers m
h
      ClientNotOrReq @t m
IsClientReq -> SClientMethod @t m
-> SMethodMap
     @'FromClient @'Request (ClientMessageHandler m 'Request)
-> Bool
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 (SMethodMap
   @'FromClient @'Request (ClientMessageHandler m 'Request)
 -> Bool)
-> SMethodMap
     @'FromClient @'Request (ClientMessageHandler m 'Request)
-> Bool
forall a b. (a -> b) -> a -> b
$ Handlers m
-> SMethodMap
     @'FromClient @'Request (ClientMessageHandler m 'Request)
forall (m :: * -> *).
Handlers m
-> SMethodMap
     @'FromClient @'Request (ClientMessageHandler m 'Request)
reqHandlers Handlers m
h
      ClientNotOrReq @t m
IsClientEither -> String -> Bool
forall a. HasCallStack => String -> a
error String
"capabilities depend on custom method"

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

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

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

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

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

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

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

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

    renameProvider :: Maybe (Bool |? RenameOptions)
renameProvider
      | Bool
clientSupportsPrepareRename
      , SClientMethod @'Request 'TextDocumentRename -> Bool
forall (t :: MethodType) (m :: Method 'FromClient t).
SClientMethod @t m -> Bool
supported_b SClientMethod @'Request 'TextDocumentRename
STextDocumentRename
      , SClientMethod @'Request 'TextDocumentPrepareRename -> Bool
forall (t :: MethodType) (m :: Method 'FromClient t).
SClientMethod @t m -> Bool
supported_b SClientMethod @'Request 'TextDocumentPrepareRename
STextDocumentPrepareRename = (Bool |? RenameOptions) -> Maybe (Bool |? RenameOptions)
forall a. a -> Maybe a
Just ((Bool |? RenameOptions) -> Maybe (Bool |? RenameOptions))
-> (Bool |? RenameOptions) -> Maybe (Bool |? RenameOptions)
forall a b. (a -> b) -> a -> b
$
          RenameOptions -> Bool |? RenameOptions
forall a b. b -> a |? b
InR (RenameOptions -> Bool |? RenameOptions)
-> (Bool -> RenameOptions) -> Bool -> Bool |? RenameOptions
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Bool -> Maybe Bool -> RenameOptions
RenameOptions Maybe Bool
forall a. Maybe a
Nothing (Maybe Bool -> RenameOptions)
-> (Bool -> Maybe Bool) -> Bool -> RenameOptions
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Maybe Bool
forall a. a -> Maybe a
Just (Bool -> Bool |? RenameOptions) -> Bool -> Bool |? RenameOptions
forall a b. (a -> b) -> a -> b
$ Bool
True
      | SClientMethod @'Request 'TextDocumentRename -> Bool
forall (t :: MethodType) (m :: Method 'FromClient t).
SClientMethod @t m -> Bool
supported_b SClientMethod @'Request 'TextDocumentRename
STextDocumentRename = (Bool |? RenameOptions) -> Maybe (Bool |? RenameOptions)
forall a. a -> Maybe a
Just (Bool -> Bool |? RenameOptions
forall a b. a -> a |? b
InL Bool
True)
      | Bool
otherwise = (Bool |? RenameOptions) -> Maybe (Bool |? RenameOptions)
forall a. a -> Maybe a
Just (Bool -> Bool |? RenameOptions
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 = (SemanticTokensOptions |? b) -> Maybe (SemanticTokensOptions |? b)
forall a. a -> Maybe a
Just ((SemanticTokensOptions |? b)
 -> Maybe (SemanticTokensOptions |? b))
-> (SemanticTokensOptions |? b)
-> Maybe (SemanticTokensOptions |? b)
forall a b. (a -> b) -> a -> b
$ SemanticTokensOptions -> SemanticTokensOptions |? b
forall a b. a -> a |? b
InL (SemanticTokensOptions -> SemanticTokensOptions |? b)
-> SemanticTokensOptions -> SemanticTokensOptions |? b
forall a b. (a -> b) -> a -> b
$ Maybe Bool
-> SemanticTokensLegend
-> Maybe SemanticTokensRangeClientCapabilities
-> Maybe SemanticTokensFullClientCapabilities
-> SemanticTokensOptions
SemanticTokensOptions Maybe Bool
forall a. Maybe a
Nothing SemanticTokensLegend
forall a. Default a => a
def Maybe SemanticTokensRangeClientCapabilities
semanticTokenRangeProvider Maybe SemanticTokensFullClientCapabilities
semanticTokenFullProvider
    semanticTokenRangeProvider :: Maybe SemanticTokensRangeClientCapabilities
semanticTokenRangeProvider
      | SClientMethod @'Request 'TextDocumentSemanticTokensRange -> Bool
forall (t :: MethodType) (m :: Method 'FromClient t).
SClientMethod @t m -> Bool
supported_b SClientMethod @'Request 'TextDocumentSemanticTokensRange
STextDocumentSemanticTokensRange = SemanticTokensRangeClientCapabilities
-> Maybe SemanticTokensRangeClientCapabilities
forall a. a -> Maybe a
Just (SemanticTokensRangeClientCapabilities
 -> Maybe SemanticTokensRangeClientCapabilities)
-> SemanticTokensRangeClientCapabilities
-> Maybe SemanticTokensRangeClientCapabilities
forall a b. (a -> b) -> a -> b
$ Bool -> SemanticTokensRangeClientCapabilities
SemanticTokensRangeBool Bool
True
      | Bool
otherwise = Maybe SemanticTokensRangeClientCapabilities
forall a. Maybe a
Nothing
    semanticTokenFullProvider :: Maybe SemanticTokensFullClientCapabilities
semanticTokenFullProvider
      | SClientMethod @'Request 'TextDocumentSemanticTokensFull -> Bool
forall (t :: MethodType) (m :: Method 'FromClient t).
SClientMethod @t m -> Bool
supported_b SClientMethod @'Request 'TextDocumentSemanticTokensFull
STextDocumentSemanticTokensFull = SemanticTokensFullClientCapabilities
-> Maybe SemanticTokensFullClientCapabilities
forall a. a -> Maybe a
Just (SemanticTokensFullClientCapabilities
 -> Maybe SemanticTokensFullClientCapabilities)
-> SemanticTokensFullClientCapabilities
-> Maybe SemanticTokensFullClientCapabilities
forall a b. (a -> b) -> a -> b
$ SemanticTokensDeltaClientCapabilities
-> SemanticTokensFullClientCapabilities
SemanticTokensFullDelta (SemanticTokensDeltaClientCapabilities
 -> SemanticTokensFullClientCapabilities)
-> SemanticTokensDeltaClientCapabilities
-> SemanticTokensFullClientCapabilities
forall a b. (a -> b) -> a -> b
$ Maybe Bool -> SemanticTokensDeltaClientCapabilities
SemanticTokensDeltaClientCapabilities (Maybe Bool -> SemanticTokensDeltaClientCapabilities)
-> Maybe Bool -> SemanticTokensDeltaClientCapabilities
forall a b. (a -> b) -> a -> b
$ SClientMethod @'Request 'TextDocumentSemanticTokensFullDelta
-> Maybe Bool
forall (t :: MethodType) (m :: Method 'FromClient t).
SClientMethod @t m -> Maybe Bool
supported SClientMethod @'Request 'TextDocumentSemanticTokensFullDelta
STextDocumentSemanticTokensFullDelta
      | Bool
otherwise = Maybe SemanticTokensFullClientCapabilities
forall a. Maybe a
Nothing

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

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

-- | 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 :: 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 -> LogAction m (WithSeverity LspProcessingLog)
-> Maybe (ClientMessage @t meth -> m ())
-> SClientMethod @t meth
-> ClientMessage @t meth
-> m ()
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 ((NotificationMessage
   @'FromClient 'WorkspaceDidChangeWorkspaceFolders
 -> LspM config ())
-> Maybe
     (NotificationMessage
        @'FromClient 'WorkspaceDidChangeWorkspaceFolders
      -> LspM config ())
forall a. a -> Maybe a
Just NotificationMessage
  @'FromClient 'WorkspaceDidChangeWorkspaceFolders
-> LspM config ()
forall config.
Message
  @'FromClient @'Notification 'WorkspaceDidChangeWorkspaceFolders
-> LspM config ()
updateWorkspaceFolders) SClientMethod @t meth
m ClientMessage @t meth
msg
    SClientMethod @t meth
SWorkspaceDidChangeConfiguration    -> LogAction m (WithSeverity LspProcessingLog)
-> Maybe (ClientMessage @t meth -> m ())
-> SClientMethod @t meth
-> ClientMessage @t meth
-> m ()
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 ((NotificationMessage @'FromClient 'WorkspaceDidChangeConfiguration
 -> LspM config ())
-> Maybe
     (NotificationMessage @'FromClient 'WorkspaceDidChangeConfiguration
      -> LspM config ())
forall a. a -> Maybe a
Just ((NotificationMessage @'FromClient 'WorkspaceDidChangeConfiguration
  -> LspM config ())
 -> Maybe
      (NotificationMessage @'FromClient 'WorkspaceDidChangeConfiguration
       -> LspM config ()))
-> (NotificationMessage
      @'FromClient 'WorkspaceDidChangeConfiguration
    -> LspM config ())
-> Maybe
     (NotificationMessage @'FromClient 'WorkspaceDidChangeConfiguration
      -> LspM config ())
forall a b. (a -> b) -> a -> b
$ LogAction m (WithSeverity LspProcessingLog)
-> Message
     @'FromClient @'Notification 'WorkspaceDidChangeConfiguration
-> m ()
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                -> LogAction m (WithSeverity LspProcessingLog)
-> Maybe (ClientMessage @t meth -> m ())
-> SClientMethod @t meth
-> ClientMessage @t meth
-> m ()
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 ((NotificationMessage @'FromClient 'TextDocumentDidOpen -> m ())
-> Maybe
     (NotificationMessage @'FromClient 'TextDocumentDidOpen -> m ())
forall a. a -> Maybe a
Just ((NotificationMessage @'FromClient 'TextDocumentDidOpen -> m ())
 -> Maybe
      (NotificationMessage @'FromClient 'TextDocumentDidOpen -> m ()))
-> (NotificationMessage @'FromClient 'TextDocumentDidOpen -> m ())
-> Maybe
     (NotificationMessage @'FromClient 'TextDocumentDidOpen -> m ())
forall a b. (a -> b) -> a -> b
$ LogAction m (WithSeverity LspProcessingLog)
-> (LogAction
      (WriterT [WithSeverity VfsLog] (State VFS)) (WithSeverity VfsLog)
    -> NotificationMessage @'FromClient 'TextDocumentDidOpen
    -> WriterT [WithSeverity VfsLog] (State VFS) ())
-> NotificationMessage @'FromClient 'TextDocumentDidOpen
-> m ()
forall (m :: * -> *) (n :: * -> *) a config.
((m :: (* -> *)) ~ (LspM config :: (* -> *)),
 (n :: (* -> *))
 ~ (WriterT [WithSeverity VfsLog] (State VFS) :: (* -> *))) =>
LogAction m (WithSeverity LspProcessingLog)
-> (LogAction n (WithSeverity VfsLog) -> a -> n ()) -> a -> m ()
vfsFunc LogAction m (WithSeverity LspProcessingLog)
logger LogAction
  (WriterT [WithSeverity VfsLog] (State VFS)) (WithSeverity VfsLog)
-> NotificationMessage @'FromClient 'TextDocumentDidOpen
-> WriterT [WithSeverity VfsLog] (State VFS) ()
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              -> LogAction m (WithSeverity LspProcessingLog)
-> Maybe (ClientMessage @t meth -> m ())
-> SClientMethod @t meth
-> ClientMessage @t meth
-> m ()
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 ((NotificationMessage @'FromClient 'TextDocumentDidChange -> m ())
-> Maybe
     (NotificationMessage @'FromClient 'TextDocumentDidChange -> m ())
forall a. a -> Maybe a
Just ((NotificationMessage @'FromClient 'TextDocumentDidChange -> m ())
 -> Maybe
      (NotificationMessage @'FromClient 'TextDocumentDidChange -> m ()))
-> (NotificationMessage @'FromClient 'TextDocumentDidChange
    -> m ())
-> Maybe
     (NotificationMessage @'FromClient 'TextDocumentDidChange -> m ())
forall a b. (a -> b) -> a -> b
$ LogAction m (WithSeverity LspProcessingLog)
-> (LogAction
      (WriterT [WithSeverity VfsLog] (State VFS)) (WithSeverity VfsLog)
    -> NotificationMessage @'FromClient 'TextDocumentDidChange
    -> WriterT [WithSeverity VfsLog] (State VFS) ())
-> NotificationMessage @'FromClient 'TextDocumentDidChange
-> m ()
forall (m :: * -> *) (n :: * -> *) a config.
((m :: (* -> *)) ~ (LspM config :: (* -> *)),
 (n :: (* -> *))
 ~ (WriterT [WithSeverity VfsLog] (State VFS) :: (* -> *))) =>
LogAction m (WithSeverity LspProcessingLog)
-> (LogAction n (WithSeverity VfsLog) -> a -> n ()) -> a -> m ()
vfsFunc LogAction m (WithSeverity LspProcessingLog)
logger LogAction
  (WriterT [WithSeverity VfsLog] (State VFS)) (WithSeverity VfsLog)
-> NotificationMessage @'FromClient 'TextDocumentDidChange
-> WriterT [WithSeverity VfsLog] (State VFS) ()
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               -> LogAction m (WithSeverity LspProcessingLog)
-> Maybe (ClientMessage @t meth -> m ())
-> SClientMethod @t meth
-> ClientMessage @t meth
-> m ()
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 ((NotificationMessage @'FromClient 'TextDocumentDidClose -> m ())
-> Maybe
     (NotificationMessage @'FromClient 'TextDocumentDidClose -> m ())
forall a. a -> Maybe a
Just ((NotificationMessage @'FromClient 'TextDocumentDidClose -> m ())
 -> Maybe
      (NotificationMessage @'FromClient 'TextDocumentDidClose -> m ()))
-> (NotificationMessage @'FromClient 'TextDocumentDidClose -> m ())
-> Maybe
     (NotificationMessage @'FromClient 'TextDocumentDidClose -> m ())
forall a b. (a -> b) -> a -> b
$ LogAction m (WithSeverity LspProcessingLog)
-> (LogAction
      (WriterT [WithSeverity VfsLog] (State VFS)) (WithSeverity VfsLog)
    -> NotificationMessage @'FromClient 'TextDocumentDidClose
    -> WriterT [WithSeverity VfsLog] (State VFS) ())
-> NotificationMessage @'FromClient 'TextDocumentDidClose
-> m ()
forall (m :: * -> *) (n :: * -> *) a config.
((m :: (* -> *)) ~ (LspM config :: (* -> *)),
 (n :: (* -> *))
 ~ (WriterT [WithSeverity VfsLog] (State VFS) :: (* -> *))) =>
LogAction m (WithSeverity LspProcessingLog)
-> (LogAction n (WithSeverity VfsLog) -> a -> n ()) -> a -> m ()
vfsFunc LogAction m (WithSeverity LspProcessingLog)
logger LogAction
  (WriterT [WithSeverity VfsLog] (State VFS)) (WithSeverity VfsLog)
-> NotificationMessage @'FromClient 'TextDocumentDidClose
-> WriterT [WithSeverity VfsLog] (State VFS) ()
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       -> LogAction m (WithSeverity LspProcessingLog)
-> Maybe (ClientMessage @t meth -> m ())
-> SClientMethod @t meth
-> ClientMessage @t meth
-> m ()
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 ((NotificationMessage @'FromClient 'WindowWorkDoneProgressCancel
 -> LspM config ())
-> Maybe
     (NotificationMessage @'FromClient 'WindowWorkDoneProgressCancel
      -> LspM config ())
forall a. a -> Maybe a
Just ((NotificationMessage @'FromClient 'WindowWorkDoneProgressCancel
  -> LspM config ())
 -> Maybe
      (NotificationMessage @'FromClient 'WindowWorkDoneProgressCancel
       -> LspM config ()))
-> (NotificationMessage @'FromClient 'WindowWorkDoneProgressCancel
    -> LspM config ())
-> Maybe
     (NotificationMessage @'FromClient 'WindowWorkDoneProgressCancel
      -> LspM config ())
forall a b. (a -> b) -> a -> b
$ LogAction m (WithSeverity LspProcessingLog)
-> Message
     @'FromClient @'Notification 'WindowWorkDoneProgressCancel
-> m ()
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
_ -> LogAction m (WithSeverity LspProcessingLog)
-> Maybe (ClientMessage @t meth -> m ())
-> SClientMethod @t meth
-> ClientMessage @t meth
-> m ()
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 ())
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' :: 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
  m ()
-> ((ClientMessage @t meth -> m ()) -> m ())
-> Maybe (ClientMessage @t meth -> m ())
-> m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> m ()
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 <- (LanguageContextState config -> TVar (RegistrationMap 'Request))
-> m (RegistrationMap 'Request)
forall config (m :: * -> *) a.
MonadLsp config m =>
(LanguageContextState config -> TVar a) -> m a
getsState LanguageContextState config -> TVar (RegistrationMap 'Request)
forall config.
LanguageContextState config -> TVar (RegistrationMap 'Request)
resRegistrationsReq
  RegistrationMap 'Notification
dynNotHandlers <- (LanguageContextState config
 -> TVar (RegistrationMap 'Notification))
-> m (RegistrationMap 'Notification)
forall config (m :: * -> *) a.
MonadLsp config m =>
(LanguageContextState config -> TVar a) -> m a
getsState LanguageContextState config -> TVar (RegistrationMap 'Notification)
forall config.
LanguageContextState config -> TVar (RegistrationMap 'Notification)
resRegistrationsNot

  LanguageContextEnv config
env <- m (LanguageContextEnv config)
forall config (m :: * -> *).
MonadLsp config m =>
m (LanguageContextEnv config)
getLspEnv
  let Handlers{SMethodMap
  @'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} = LanguageContextEnv config -> Handlers IO
forall config. LanguageContextEnv config -> Handlers IO
resHandlers LanguageContextEnv config
env

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

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

    ClientNotOrReq @t meth
IsClientEither -> case ClientMessage @t meth
msg of
      NotMess noti -> case RegistrationMap t
-> SMethodMap @'FromClient @t (ClientMessageHandler IO t)
-> Maybe (Handler @'FromClient @t IO meth)
pickHandler RegistrationMap t
RegistrationMap 'Notification
dynNotHandlers SMethodMap @'FromClient @t (ClientMessageHandler IO t)
SMethodMap
  @'FromClient @'Notification (ClientMessageHandler IO 'Notification)
notHandlers of
        Just Handler @'FromClient @t IO meth
h -> IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Handler @'FromClient @t IO meth
NotificationMessage
  @'FromClient ('CustomMethod @'FromClient @'Notification)
-> IO ()
h NotificationMessage
  @'FromClient ('CustomMethod @'FromClient @'Notification)
noti
        Maybe (Handler @'FromClient @t IO meth)
Nothing -> m ()
reportMissingHandler
      ReqMess req -> case RegistrationMap t
-> SMethodMap @'FromClient @t (ClientMessageHandler IO t)
-> Maybe (Handler @'FromClient @t IO meth)
pickHandler RegistrationMap t
RegistrationMap 'Request
dynReqHandlers SMethodMap @'FromClient @t (ClientMessageHandler IO t)
SMethodMap
  @'FromClient @'Request (ClientMessageHandler IO 'Request)
reqHandlers of
        Just Handler @'FromClient @t IO meth
h -> IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Handler @'FromClient @t IO meth
RequestMessage @'FromClient ('CustomMethod @'FromClient @'Request)
-> (Either ResponseError Value -> IO ()) -> IO ()
h RequestMessage @'FromClient ('CustomMethod @'FromClient @'Request)
req (RequestMessage @'FromClient ('CustomMethod @'FromClient @'Request)
-> Either
     ResponseError
     (ResponseResult
        @'FromClient ('CustomMethod @'FromClient @'Request))
-> IO ()
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 (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String
"lsp:no handler for: ", SClientMethod @t meth -> String
forall a. Show a => a -> String
show SClientMethod @t meth
m]
              err :: ResponseError
err = ErrorCode -> Text -> Maybe Value -> ResponseError
ResponseError ErrorCode
MethodNotFound Text
errorMsg Maybe Value
forall a. Maybe a
Nothing
          FromServerMessage -> m ()
forall config (m :: * -> *).
MonadLsp config m =>
FromServerMessage -> m ()
sendToClient (FromServerMessage -> m ()) -> FromServerMessage -> m ()
forall a b. (a -> b) -> a -> b
$
            SMethod
  @'FromClient @'Request ('CustomMethod @'FromClient @'Request)
-> ResponseMessage
     @'FromClient ('CustomMethod @'FromClient @'Request)
-> FromServerMessage
forall (m :: Method 'FromClient 'Request)
       (a :: Method 'FromClient 'Request -> *).
a m -> ResponseMessage @'FromClient m -> FromServerMessage' a
FromServerRsp (RequestMessage @'FromClient ('CustomMethod @'FromClient @'Request)
req RequestMessage @'FromClient ('CustomMethod @'FromClient @'Request)
-> Getting
     (SMethod
        @'FromClient @'Request ('CustomMethod @'FromClient @'Request))
     (RequestMessage
        @'FromClient ('CustomMethod @'FromClient @'Request))
     (SMethod
        @'FromClient @'Request ('CustomMethod @'FromClient @'Request))
-> SMethod
     @'FromClient @'Request ('CustomMethod @'FromClient @'Request)
forall s a. s -> Getting a s a -> a
^. Getting
  (SMethod
     @'FromClient @'Request ('CustomMethod @'FromClient @'Request))
  (RequestMessage
     @'FromClient ('CustomMethod @'FromClient @'Request))
  (SMethod
     @'FromClient @'Request ('CustomMethod @'FromClient @'Request))
forall s a. HasMethod s a => Lens' s a
LSP.method) (ResponseMessage
   @'FromClient ('CustomMethod @'FromClient @'Request)
 -> FromServerMessage)
-> ResponseMessage
     @'FromClient ('CustomMethod @'FromClient @'Request)
-> FromServerMessage
forall a b. (a -> b) -> a -> b
$ Text
-> Maybe
     (LspId @'FromClient ('CustomMethod @'FromClient @'Request))
-> Either
     ResponseError
     (ResponseResult
        @'FromClient ('CustomMethod @'FromClient @'Request))
-> ResponseMessage
     @'FromClient ('CustomMethod @'FromClient @'Request)
forall (f :: From) (m :: Method f 'Request).
Text
-> Maybe (LspId @f m)
-> Either ResponseError (ResponseResult @f m)
-> ResponseMessage @f m
ResponseMessage Text
"2.0" (LspId @'FromClient ('CustomMethod @'FromClient @'Request)
-> Maybe
     (LspId @'FromClient ('CustomMethod @'FromClient @'Request))
forall a. a -> Maybe a
Just (RequestMessage @'FromClient ('CustomMethod @'FromClient @'Request)
req RequestMessage @'FromClient ('CustomMethod @'FromClient @'Request)
-> Getting
     (LspId @'FromClient ('CustomMethod @'FromClient @'Request))
     (RequestMessage
        @'FromClient ('CustomMethod @'FromClient @'Request))
     (LspId @'FromClient ('CustomMethod @'FromClient @'Request))
-> LspId @'FromClient ('CustomMethod @'FromClient @'Request)
forall s a. s -> Getting a s a -> a
^. Getting
  (LspId @'FromClient ('CustomMethod @'FromClient @'Request))
  (RequestMessage
     @'FromClient ('CustomMethod @'FromClient @'Request))
  (LspId @'FromClient ('CustomMethod @'FromClient @'Request))
forall s a. HasId s a => Lens' s a
LSP.id)) (ResponseError -> Either ResponseError Value
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 (SClientMethod @t meth
-> RegistrationMap t
-> Maybe
     (Product
        @(Method 'FromClient t)
        (RegistrationId @t)
        (ClientMessageHandler IO t)
        meth)
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, SClientMethod @t meth
-> SMethodMap @'FromClient @t (ClientMessageHandler IO t)
-> Maybe (ClientMessageHandler IO t meth)
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)
_) -> Handler @'FromClient @t IO meth
-> Maybe (Handler @'FromClient @t IO 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)) -> Handler @'FromClient @t IO meth
-> Maybe (Handler @'FromClient @t IO 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, Maybe (ClientMessageHandler IO t meth)
Nothing) -> Maybe (Handler @'FromClient @t IO meth)
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 = SClientMethod @t meth -> Bool
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 LogAction m (WithSeverity LspProcessingLog)
-> WithSeverity LspProcessingLog -> m ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& Bool -> SClientMethod @t meth -> LspProcessingLog
forall (t :: MethodType) (m :: Method 'FromClient t).
Bool -> SClientMethod @t m -> LspProcessingLog
MissingHandler Bool
optional SClientMethod @t meth
m LspProcessingLog -> Severity -> WithSeverity LspProcessingLog
forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` if Bool
optional then Severity
Warning else Severity
Error
    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 :: LogAction m (WithSeverity LspProcessingLog)
-> Message
     @'FromClient @'Notification 'WindowWorkDoneProgressCancel
-> m ()
progressCancelHandler LogAction m (WithSeverity LspProcessingLog)
logger (NotificationMessage _ _ (WorkDoneProgressCancelParams tid)) = do
  Map ProgressToken (IO ())
pdata <- (LanguageContextState config -> TVar (Map ProgressToken (IO ())))
-> m (Map ProgressToken (IO ()))
forall config (m :: * -> *) a.
MonadLsp config m =>
(LanguageContextState config -> TVar a) -> m a
getsState (ProgressData -> TVar (Map ProgressToken (IO ()))
progressCancel (ProgressData -> TVar (Map ProgressToken (IO ())))
-> (LanguageContextState config -> ProgressData)
-> LanguageContextState config
-> TVar (Map ProgressToken (IO ()))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LanguageContextState config -> ProgressData
forall config. LanguageContextState config -> ProgressData
resProgressData)
  case ProgressToken -> Map ProgressToken (IO ()) -> Maybe (IO ())
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ProgressToken
tid Map ProgressToken (IO ())
pdata of
    Maybe (IO ())
Nothing -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just IO ()
cancelAction -> do
      LogAction m (WithSeverity LspProcessingLog)
logger LogAction m (WithSeverity LspProcessingLog)
-> WithSeverity LspProcessingLog -> m ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& ProgressToken -> LspProcessingLog
ProgressCancel ProgressToken
tid LspProcessingLog -> Severity -> WithSeverity LspProcessingLog
forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` Severity
Debug
      IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
cancelAction

exitNotificationHandler :: (MonadIO m) => LogAction m (WithSeverity LspProcessingLog) -> Handler m Exit
exitNotificationHandler :: LogAction m (WithSeverity LspProcessingLog)
-> Handler @'FromClient @'Notification m 'Exit
exitNotificationHandler LogAction m (WithSeverity LspProcessingLog)
logger NotificationMessage @'FromClient 'Exit
_ = do
  LogAction m (WithSeverity LspProcessingLog)
logger LogAction m (WithSeverity LspProcessingLog)
-> WithSeverity LspProcessingLog -> m ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& LspProcessingLog
Exiting LspProcessingLog -> Severity -> WithSeverity LspProcessingLog
forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` Severity
Info
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
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 (Either ResponseError Empty -> IO ())
-> Either ResponseError Empty -> IO ()
forall a b. (a -> b) -> a -> b
$ Empty -> Either ResponseError Empty
forall a b. b -> Either a b
Right Empty
Empty

handleConfigChange :: (m ~ LspM config) => LogAction m (WithSeverity LspProcessingLog) -> Message WorkspaceDidChangeConfiguration -> m ()
handleConfigChange :: 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 <- ReaderT
  (LanguageContextEnv config)
  IO
  (config -> Value -> Either Text config)
-> LspT config IO (config -> Value -> Either Text config)
forall config (m :: * -> *) a.
ReaderT (LanguageContextEnv config) m a -> LspT config m a
LspT (ReaderT
   (LanguageContextEnv config)
   IO
   (config -> Value -> Either Text config)
 -> LspT config IO (config -> Value -> Either Text config))
-> ReaderT
     (LanguageContextEnv config)
     IO
     (config -> Value -> Either Text config)
-> LspT config IO (config -> Value -> Either Text config)
forall a b. (a -> b) -> a -> b
$ (LanguageContextEnv config
 -> config -> Value -> Either Text config)
-> ReaderT
     (LanguageContextEnv config)
     IO
     (config -> Value -> Either Text config)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks LanguageContextEnv config -> config -> Value -> Either Text config
forall config.
LanguageContextEnv config -> config -> Value -> Either Text config
resParseConfig
  let settings :: Value
settings = Message
  @'FromClient @'Notification 'WorkspaceDidChangeConfiguration
NotificationMessage @'FromClient 'WorkspaceDidChangeConfiguration
req NotificationMessage @'FromClient 'WorkspaceDidChangeConfiguration
-> Getting
     Value
     (NotificationMessage @'FromClient 'WorkspaceDidChangeConfiguration)
     Value
-> Value
forall s a. s -> Getting a s a -> a
^. (DidChangeConfigurationParams
 -> Const @* Value DidChangeConfigurationParams)
-> NotificationMessage
     @'FromClient 'WorkspaceDidChangeConfiguration
-> Const
     @*
     Value
     (NotificationMessage @'FromClient 'WorkspaceDidChangeConfiguration)
forall s a. HasParams s a => Lens' s a
LSP.params ((DidChangeConfigurationParams
  -> Const @* Value DidChangeConfigurationParams)
 -> NotificationMessage
      @'FromClient 'WorkspaceDidChangeConfiguration
 -> Const
      @*
      Value
      (NotificationMessage
         @'FromClient 'WorkspaceDidChangeConfiguration))
-> ((Value -> Const @* Value Value)
    -> DidChangeConfigurationParams
    -> Const @* Value DidChangeConfigurationParams)
-> Getting
     Value
     (NotificationMessage @'FromClient 'WorkspaceDidChangeConfiguration)
     Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> Const @* Value Value)
-> DidChangeConfigurationParams
-> Const @* Value DidChangeConfigurationParams
forall s a. HasSettings s a => Lens' s a
LSP.settings
  Either Text ()
res <- (LanguageContextState config -> TVar config)
-> (config -> (Either Text (), config)) -> m (Either Text ())
forall config (m :: * -> *) s a.
MonadLsp config m =>
(LanguageContextState config -> TVar s) -> (s -> (a, s)) -> m a
stateState LanguageContextState config -> TVar config
forall config. LanguageContextState config -> TVar config
resConfig ((config -> (Either Text (), config)) -> m (Either Text ()))
-> (config -> (Either Text (), config)) -> m (Either Text ())
forall a b. (a -> b) -> a -> b
$ \config
oldConfig -> case config -> Value -> Either Text config
parseConfig config
oldConfig Value
settings of
    Left Text
err -> (Text -> Either Text ()
forall a b. a -> Either a b
Left Text
err, config
oldConfig)
    Right !config
newConfig -> (() -> Either Text ()
forall a b. b -> Either a b
Right (), config
newConfig)
  case Either Text ()
res of
    Left Text
err -> do
      LogAction m (WithSeverity LspProcessingLog)
logger LogAction m (WithSeverity LspProcessingLog)
-> WithSeverity LspProcessingLog -> m ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& Value -> Text -> LspProcessingLog
ConfigurationParseError Value
settings Text
err LspProcessingLog -> Severity -> WithSeverity LspProcessingLog
forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` Severity
Error
    Right () -> () -> m ()
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 :: LogAction m (WithSeverity LspProcessingLog)
-> (LogAction n (WithSeverity VfsLog) -> a -> n ()) -> a -> m ()
vfsFunc LogAction m (WithSeverity LspProcessingLog)
logger LogAction n (WithSeverity VfsLog) -> a -> n ()
modifyVfs a
req = do
  -- This is an intricate dance. We want to run the VFS functions essentially in STM, that's
  -- what 'stateState' does. But we also want them to log. We accomplish this by exfiltrating
  -- the logs through the return value of 'stateState' and then re-logging them.
  -- We therefore have to use the stupid approach of accumulating the logs in Writer inside
  -- the VFS functions. They don't log much so for now we just use [Log], but we could use
  -- DList here if we're worried about performance.
  [WithSeverity VfsLog]
logs <- (LanguageContextState config -> TVar VFSData)
-> (VFSData -> ([WithSeverity VfsLog], VFSData))
-> m [WithSeverity VfsLog]
forall config (m :: * -> *) s a.
MonadLsp config m =>
(LanguageContextState config -> TVar s) -> (s -> (a, s)) -> m a
stateState LanguageContextState config -> TVar VFSData
forall config. LanguageContextState config -> TVar VFSData
resVFS ((VFSData -> ([WithSeverity VfsLog], VFSData))
 -> m [WithSeverity VfsLog])
-> (VFSData -> ([WithSeverity VfsLog], VFSData))
-> m [WithSeverity VfsLog]
forall a b. (a -> b) -> a -> b
$ \(VFSData VFS
vfs Map String String
rm) ->
    let ([WithSeverity VfsLog]
ls, VFS
vfs') = (State VFS [WithSeverity VfsLog]
 -> VFS -> ([WithSeverity VfsLog], VFS))
-> VFS
-> State VFS [WithSeverity VfsLog]
-> ([WithSeverity VfsLog], VFS)
forall a b c. (a -> b -> c) -> b -> a -> c
flip State VFS [WithSeverity VfsLog]
-> VFS -> ([WithSeverity VfsLog], VFS)
forall s a. State s a -> s -> (a, s)
runState VFS
vfs (State VFS [WithSeverity VfsLog] -> ([WithSeverity VfsLog], VFS))
-> State VFS [WithSeverity VfsLog] -> ([WithSeverity VfsLog], VFS)
forall a b. (a -> b) -> a -> b
$ WriterT [WithSeverity VfsLog] (State VFS) ()
-> State VFS [WithSeverity VfsLog]
forall (m :: * -> *) w a. Monad m => WriterT w m a -> m w
execWriterT (WriterT [WithSeverity VfsLog] (State VFS) ()
 -> State VFS [WithSeverity VfsLog])
-> WriterT [WithSeverity VfsLog] (State VFS) ()
-> State VFS [WithSeverity VfsLog]
forall a b. (a -> b) -> a -> b
$ LogAction n (WithSeverity VfsLog) -> a -> n ()
modifyVfs LogAction n (WithSeverity VfsLog)
innerLogger a
req
    in ([WithSeverity VfsLog]
ls, VFS -> Map String String -> VFSData
VFSData VFS
vfs' Map String String
rm)
  (WithSeverity VfsLog -> m ()) -> [WithSeverity VfsLog] -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\WithSeverity VfsLog
l -> LogAction m (WithSeverity LspProcessingLog)
logger LogAction m (WithSeverity LspProcessingLog)
-> WithSeverity LspProcessingLog -> m ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& (VfsLog -> LspProcessingLog)
-> WithSeverity VfsLog -> WithSeverity LspProcessingLog
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap VfsLog -> LspProcessingLog
VfsLog WithSeverity VfsLog
l) [WithSeverity VfsLog]
logs
    where
      innerLogger :: LogAction n (WithSeverity VfsLog)
      innerLogger :: LogAction n (WithSeverity VfsLog)
innerLogger = (WithSeverity VfsLog -> n ()) -> LogAction n (WithSeverity VfsLog)
forall (m :: * -> *) msg. (msg -> m ()) -> LogAction m msg
LogAction ((WithSeverity VfsLog -> n ())
 -> LogAction n (WithSeverity VfsLog))
-> (WithSeverity VfsLog -> n ())
-> LogAction n (WithSeverity VfsLog)
forall a b. (a -> b) -> a -> b
$ \WithSeverity VfsLog
m -> [WithSeverity VfsLog] -> n ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [WithSeverity VfsLog
m]

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

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