{-# LANGUAGE TypeInType #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE BangPatterns #-}
{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
module Language.LSP.Server.Processing where

import Control.Lens hiding (List, Empty)
import Data.Aeson hiding (Options)
import Data.Aeson.Types hiding (Options)
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 as TL
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
import Data.Functor.Product
import qualified Control.Exception as E
import Data.Monoid hiding (Product)
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 System.Log.Logger
import Data.Maybe
import qualified Data.Map.Strict as Map
import System.Exit
import Data.Default (def)

processMessage :: BSL.ByteString -> LspM config ()
processMessage :: ByteString -> LspM config ()
processMessage 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
  LspT config IO (LspM config ()) -> LspM config ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (LspT config IO (LspM config ()) -> LspM config ())
-> LspT config IO (LspM config ()) -> LspM config ()
forall a b. (a -> b) -> a -> b
$ IO (LspM config ()) -> LspT config IO (LspM config ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (LspM config ()) -> LspT config IO (LspM config ()))
-> IO (LspM config ()) -> LspT config IO (LspM config ())
forall a b. (a -> b) -> a -> b
$ STM (LspM config ()) -> IO (LspM config ())
forall a. STM a -> IO a
atomically (STM (LspM config ()) -> IO (LspM config ()))
-> STM (LspM config ()) -> IO (LspM config ())
forall a b. (a -> b) -> a -> b
$ (Either String (LspM config ()) -> LspM config ())
-> STM (Either String (LspM config ())) -> STM (LspM config ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either String (LspM config ()) -> LspM config ()
handleErrors (STM (Either String (LspM config ())) -> STM (LspM config ()))
-> STM (Either String (LspM config ())) -> STM (LspM config ())
forall a b. (a -> b) -> a -> b
$ ExceptT String STM (LspM config ())
-> STM (Either String (LspM config ()))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT String STM (LspM config ())
 -> STM (Either String (LspM config ())))
-> ExceptT String STM (LspM config ())
-> STM (Either String (LspM config ()))
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 (LspM config ()) -> ExceptT String STM (LspM config ())
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (STM (LspM config ()) -> ExceptT String STM (LspM config ()))
-> STM (LspM config ()) -> ExceptT String STM (LspM config ())
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 ->
          LspM config () -> STM (LspM config ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LspM config () -> STM (LspM config ()))
-> LspM config () -> STM (LspM config ())
forall a b. (a -> b) -> a -> b
$ SMethod @'FromClient @t m
-> Message @'FromClient @t m -> LspM config ()
forall (t :: MethodType) (m :: Method 'FromClient t) config.
SClientMethod @t m -> ClientMessage @t m -> LspM config ()
handle SMethod @'FromClient @t m
m Message @'FromClient @t m
mess
        FromClientRsp (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
          LspM config () -> STM (LspM config ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LspM config () -> STM (LspM config ()))
-> LspM config () -> STM (LspM config ())
forall a b. (a -> b) -> a -> b
$ IO () -> LspM config ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> LspM config ()) -> IO () -> LspM config ()
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' (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 (\(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
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 (LspM config ()) -> LspM config ()
handleErrors = (String -> LspM config ())
-> (LspM config () -> LspM config ())
-> Either String (LspM config ())
-> LspM config ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> LspM config ()
forall config (m :: * -> *). MonadLsp config m => Text -> m ()
sendErrorLog (Text -> LspM config ())
-> (String -> Text) -> String -> LspM config ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
errMsg) LspM config () -> LspM config ()
forall a. a -> a
id

    errMsg :: String -> Text
errMsg String
err = Text -> Text
TL.toStrict (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
TL.unwords
      [ Text
"lsp:incoming message parse error."
      , ByteString -> Text
TL.decodeUtf8 ByteString
jsonStr
      , String -> Text
TL.pack String
err
      ] Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"

-- | 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
-> 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
_workspaceSymbolProvider          = SClientMethod @'Request 'WorkspaceSymbol -> Maybe Bool
forall (t :: MethodType) (m :: Method 'FromClient t).
SClientMethod @t m -> Maybe Bool
supported 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 :: SClientMethod m -> ClientMessage m -> LspM config ()
handle :: SClientMethod @t m -> ClientMessage @t m -> LspM config ()
handle SClientMethod @t m
m ClientMessage @t m
msg =
  case SClientMethod @t m
m of
    SClientMethod @t m
SWorkspaceDidChangeWorkspaceFolders -> Maybe (ClientMessage @t m -> LspM config ())
-> SClientMethod @t m -> ClientMessage @t m -> LspM config ()
forall (t :: MethodType) (m :: Method 'FromClient t) config.
Maybe (ClientMessage @t m -> LspM config ())
-> SClientMethod @t m -> ClientMessage @t m -> LspM config ()
handle' ((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 m
m ClientMessage @t m
msg
    SClientMethod @t m
SWorkspaceDidChangeConfiguration    -> Maybe (ClientMessage @t m -> LspM config ())
-> SClientMethod @t m -> ClientMessage @t m -> LspM config ()
forall (t :: MethodType) (m :: Method 'FromClient t) config.
Maybe (ClientMessage @t m -> LspM config ())
-> SClientMethod @t m -> ClientMessage @t m -> LspM config ()
handle' ((NotificationMessage @'FromClient 'WorkspaceDidChangeConfiguration
 -> LspM config ())
-> Maybe
     (NotificationMessage @'FromClient 'WorkspaceDidChangeConfiguration
      -> LspM config ())
forall a. a -> Maybe a
Just NotificationMessage @'FromClient 'WorkspaceDidChangeConfiguration
-> LspM config ()
forall config.
Message
  @'FromClient @'Notification 'WorkspaceDidChangeConfiguration
-> LspM config ()
handleConfigChange) SClientMethod @t m
m ClientMessage @t m
msg
    SClientMethod @t m
STextDocumentDidOpen                -> Maybe (ClientMessage @t m -> LspM config ())
-> SClientMethod @t m -> ClientMessage @t m -> LspM config ()
forall (t :: MethodType) (m :: Method 'FromClient t) config.
Maybe (ClientMessage @t m -> LspM config ())
-> SClientMethod @t m -> ClientMessage @t m -> LspM config ()
handle' ((NotificationMessage @'FromClient 'TextDocumentDidOpen
 -> LspM config ())
-> Maybe
     (NotificationMessage @'FromClient 'TextDocumentDidOpen
      -> LspM config ())
forall a. a -> Maybe a
Just ((NotificationMessage @'FromClient 'TextDocumentDidOpen
  -> LspM config ())
 -> Maybe
      (NotificationMessage @'FromClient 'TextDocumentDidOpen
       -> LspM config ()))
-> (NotificationMessage @'FromClient 'TextDocumentDidOpen
    -> LspM config ())
-> Maybe
     (NotificationMessage @'FromClient 'TextDocumentDidOpen
      -> LspM config ())
forall a b. (a -> b) -> a -> b
$ (VFS
 -> NotificationMessage @'FromClient 'TextDocumentDidOpen
 -> (VFS, [String]))
-> NotificationMessage @'FromClient 'TextDocumentDidOpen
-> LspM config ()
forall b config.
(VFS -> b -> (VFS, [String])) -> b -> LspM config ()
vfsFunc VFS
-> Message @'FromClient @'Notification 'TextDocumentDidOpen
-> (VFS, [String])
VFS
-> NotificationMessage @'FromClient 'TextDocumentDidOpen
-> (VFS, [String])
openVFS) SClientMethod @t m
m ClientMessage @t m
msg
    SClientMethod @t m
STextDocumentDidChange              -> Maybe (ClientMessage @t m -> LspM config ())
-> SClientMethod @t m -> ClientMessage @t m -> LspM config ()
forall (t :: MethodType) (m :: Method 'FromClient t) config.
Maybe (ClientMessage @t m -> LspM config ())
-> SClientMethod @t m -> ClientMessage @t m -> LspM config ()
handle' ((NotificationMessage @'FromClient 'TextDocumentDidChange
 -> LspM config ())
-> Maybe
     (NotificationMessage @'FromClient 'TextDocumentDidChange
      -> LspM config ())
forall a. a -> Maybe a
Just ((NotificationMessage @'FromClient 'TextDocumentDidChange
  -> LspM config ())
 -> Maybe
      (NotificationMessage @'FromClient 'TextDocumentDidChange
       -> LspM config ()))
-> (NotificationMessage @'FromClient 'TextDocumentDidChange
    -> LspM config ())
-> Maybe
     (NotificationMessage @'FromClient 'TextDocumentDidChange
      -> LspM config ())
forall a b. (a -> b) -> a -> b
$ (VFS
 -> NotificationMessage @'FromClient 'TextDocumentDidChange
 -> (VFS, [String]))
-> NotificationMessage @'FromClient 'TextDocumentDidChange
-> LspM config ()
forall b config.
(VFS -> b -> (VFS, [String])) -> b -> LspM config ()
vfsFunc VFS
-> Message @'FromClient @'Notification 'TextDocumentDidChange
-> (VFS, [String])
VFS
-> NotificationMessage @'FromClient 'TextDocumentDidChange
-> (VFS, [String])
changeFromClientVFS) SClientMethod @t m
m ClientMessage @t m
msg
    SClientMethod @t m
STextDocumentDidClose               -> Maybe (ClientMessage @t m -> LspM config ())
-> SClientMethod @t m -> ClientMessage @t m -> LspM config ()
forall (t :: MethodType) (m :: Method 'FromClient t) config.
Maybe (ClientMessage @t m -> LspM config ())
-> SClientMethod @t m -> ClientMessage @t m -> LspM config ()
handle' ((NotificationMessage @'FromClient 'TextDocumentDidClose
 -> LspM config ())
-> Maybe
     (NotificationMessage @'FromClient 'TextDocumentDidClose
      -> LspM config ())
forall a. a -> Maybe a
Just ((NotificationMessage @'FromClient 'TextDocumentDidClose
  -> LspM config ())
 -> Maybe
      (NotificationMessage @'FromClient 'TextDocumentDidClose
       -> LspM config ()))
-> (NotificationMessage @'FromClient 'TextDocumentDidClose
    -> LspM config ())
-> Maybe
     (NotificationMessage @'FromClient 'TextDocumentDidClose
      -> LspM config ())
forall a b. (a -> b) -> a -> b
$ (VFS
 -> NotificationMessage @'FromClient 'TextDocumentDidClose
 -> (VFS, [String]))
-> NotificationMessage @'FromClient 'TextDocumentDidClose
-> LspM config ()
forall b config.
(VFS -> b -> (VFS, [String])) -> b -> LspM config ()
vfsFunc VFS
-> Message @'FromClient @'Notification 'TextDocumentDidClose
-> (VFS, [String])
VFS
-> NotificationMessage @'FromClient 'TextDocumentDidClose
-> (VFS, [String])
closeVFS) SClientMethod @t m
m ClientMessage @t m
msg
    SClientMethod @t m
SWindowWorkDoneProgressCancel       -> Maybe (ClientMessage @t m -> LspM config ())
-> SClientMethod @t m -> ClientMessage @t m -> LspM config ()
forall (t :: MethodType) (m :: Method 'FromClient t) config.
Maybe (ClientMessage @t m -> LspM config ())
-> SClientMethod @t m -> ClientMessage @t m -> LspM config ()
handle' ((NotificationMessage @'FromClient 'WindowWorkDoneProgressCancel
 -> LspM config ())
-> Maybe
     (NotificationMessage @'FromClient 'WindowWorkDoneProgressCancel
      -> LspM config ())
forall a. a -> Maybe a
Just NotificationMessage @'FromClient 'WindowWorkDoneProgressCancel
-> LspM config ()
forall config.
Message @'FromClient @'Notification 'WindowWorkDoneProgressCancel
-> LspM config ()
progressCancelHandler) SClientMethod @t m
m ClientMessage @t m
msg
    SClientMethod @t m
_ -> Maybe (ClientMessage @t m -> LspM config ())
-> SClientMethod @t m -> ClientMessage @t m -> LspM config ()
forall (t :: MethodType) (m :: Method 'FromClient t) config.
Maybe (ClientMessage @t m -> LspM config ())
-> SClientMethod @t m -> ClientMessage @t m -> LspM config ()
handle' Maybe (ClientMessage @t m -> LspM config ())
forall a. Maybe a
Nothing SClientMethod @t m
m ClientMessage @t m
msg


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

  RegistrationMap 'Request
dynReqHandlers <- (LanguageContextState config -> TVar (RegistrationMap 'Request))
-> LspT config IO (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))
-> LspT config IO (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 <- LspT config IO (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 -> LspM config () -> IO ()
forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
runLspT LanguageContextEnv config
env (LspM config () -> IO ()) -> LspM config () -> IO ()
forall a b. (a -> b) -> a -> b
$ FromServerMessage -> LspM config ()
forall config (m :: * -> *).
MonadLsp config m =>
FromServerMessage -> m ()
sendToClient (FromServerMessage -> LspM config ())
-> FromServerMessage -> LspM config ()
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 -> LspM config () -> IO ()
forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
runLspT LanguageContextEnv config
env (LspM config () -> IO ()) -> LspM config () -> IO ()
forall a b. (a -> b) -> a -> b
$ FromServerMessage -> LspM config ()
forall config (m :: * -> *).
MonadLsp config m =>
FromServerMessage -> m ()
sendToClient (FromServerMessage -> LspM config ())
-> FromServerMessage -> LspM config ()
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 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 -> case RegistrationMap t
-> SMethodMap @'FromClient @t (ClientMessageHandler IO t)
-> Maybe (Handler @'FromClient @t IO m)
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 m
h -> IO () -> LspM config ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> LspM config ()) -> IO () -> LspM config ()
forall a b. (a -> b) -> a -> b
$ Handler @'FromClient @t IO m
NotificationMessage @'FromClient m -> IO ()
h ClientMessage @t m
NotificationMessage @'FromClient m
msg
      Maybe (Handler @'FromClient @t IO m)
Nothing
        | SClientMethod @t m
SExit <- SClientMethod @t m
m -> IO () -> LspM config ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> LspM config ()) -> IO () -> LspM config ()
forall a b. (a -> b) -> a -> b
$ Handler @'FromClient @'Notification IO 'Exit
NotificationMessage @'FromClient 'Exit -> IO ()
exitNotificationHandler ClientMessage @t m
NotificationMessage @'FromClient 'Exit
msg
        | Bool
otherwise -> do
            LspM config ()
reportMissingHandler

    ClientNotOrReq @t m
IsClientReq -> case RegistrationMap t
-> SMethodMap @'FromClient @t (ClientMessageHandler IO t)
-> Maybe (Handler @'FromClient @t IO m)
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 m
h -> IO () -> LspM config ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> LspM config ()) -> IO () -> LspM config ()
forall a b. (a -> b) -> a -> b
$ Handler @'FromClient @t IO m
RequestMessage @'FromClient m
-> (Either ResponseError (ResponseResult @'FromClient m) -> IO ())
-> IO ()
h ClientMessage @t m
RequestMessage @'FromClient m
msg (RequestMessage @'FromClient m
-> Either ResponseError (ResponseResult @'FromClient m) -> IO ()
forall (m1 :: Method 'FromClient 'Request).
RequestMessage @'FromClient m1
-> Either ResponseError (ResponseResult @'FromClient m1) -> IO ()
mkRspCb ClientMessage @t m
RequestMessage @'FromClient m
msg)
      Maybe (Handler @'FromClient @t IO m)
Nothing
        | SClientMethod @t m
SShutdown <- SClientMethod @t m
m -> IO () -> LspM config ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> LspM config ()) -> IO () -> LspM config ()
forall a b. (a -> b) -> a -> b
$ Handler @'FromClient @'Request IO 'Shutdown
RequestMessage @'FromClient 'Shutdown
-> (Either ResponseError Empty -> IO ()) -> IO ()
shutdownRequestHandler ClientMessage @t m
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 m
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 m -> String
forall a. Show a => a -> String
show SClientMethod @t m
m]
                err :: ResponseError
err = ErrorCode -> Text -> Maybe Value -> ResponseError
ResponseError ErrorCode
MethodNotFound Text
errorMsg Maybe Value
forall a. Maybe a
Nothing
            FromServerMessage -> LspM config ()
forall config (m :: * -> *).
MonadLsp config m =>
FromServerMessage -> m ()
sendToClient (FromServerMessage -> LspM config ())
-> FromServerMessage -> LspM config ()
forall a b. (a -> b) -> a -> b
$
              SMethod @'FromClient @'Request m
-> ResponseMessage @'FromClient m -> FromServerMessage
forall (m :: Method 'FromClient 'Request)
       (a :: Method 'FromClient 'Request -> *).
a m -> ResponseMessage @'FromClient m -> FromServerMessage' a
FromServerRsp (ClientMessage @t m
RequestMessage @'FromClient m
msg RequestMessage @'FromClient m
-> Getting
     (SMethod @'FromClient @'Request m)
     (RequestMessage @'FromClient m)
     (SMethod @'FromClient @'Request m)
-> SMethod @'FromClient @'Request m
forall s a. s -> Getting a s a -> a
^. Getting
  (SMethod @'FromClient @'Request m)
  (RequestMessage @'FromClient m)
  (SMethod @'FromClient @'Request m)
forall s a. HasMethod s a => Lens' s a
LSP.method) (ResponseMessage @'FromClient m -> FromServerMessage)
-> ResponseMessage @'FromClient m -> FromServerMessage
forall a b. (a -> b) -> a -> b
$ Text
-> Maybe (LspId @'FromClient m)
-> Either ResponseError (ResponseResult @'FromClient m)
-> ResponseMessage @'FromClient 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 @'FromClient m -> Maybe (LspId @'FromClient m)
forall a. a -> Maybe a
Just (ClientMessage @t m
RequestMessage @'FromClient m
msg RequestMessage @'FromClient m
-> Getting
     (LspId @'FromClient m)
     (RequestMessage @'FromClient m)
     (LspId @'FromClient m)
-> LspId @'FromClient m
forall s a. s -> Getting a s a -> a
^. Getting
  (LspId @'FromClient m)
  (RequestMessage @'FromClient m)
  (LspId @'FromClient m)
forall s a. HasId s a => Lens' s a
LSP.id)) (ResponseError
-> Either ResponseError (ResponseResult @'FromClient m)
forall a b. a -> Either a b
Left ResponseError
err)

    ClientNotOrReq @t m
IsClientEither -> case ClientMessage @t m
msg of
      NotMess noti -> case RegistrationMap t
-> SMethodMap @'FromClient @t (ClientMessageHandler IO t)
-> Maybe (Handler @'FromClient @t IO m)
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 m
h -> IO () -> LspM config ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> LspM config ()) -> IO () -> LspM config ()
forall a b. (a -> b) -> a -> b
$ Handler @'FromClient @t IO m
NotificationMessage
  @'FromClient ('CustomMethod @'FromClient @'Notification)
-> IO ()
h NotificationMessage
  @'FromClient ('CustomMethod @'FromClient @'Notification)
noti
        Maybe (Handler @'FromClient @t IO m)
Nothing -> LspM config ()
reportMissingHandler
      ReqMess req -> case RegistrationMap t
-> SMethodMap @'FromClient @t (ClientMessageHandler IO t)
-> Maybe (Handler @'FromClient @t IO m)
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 m
h -> IO () -> LspM config ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> LspM config ()) -> IO () -> LspM config ()
forall a b. (a -> b) -> a -> b
$ Handler @'FromClient @t IO m
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 m)
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 m -> String
forall a. Show a => a -> String
show SClientMethod @t m
m]
              err :: ResponseError
err = ErrorCode -> Text -> Maybe Value -> ResponseError
ResponseError ErrorCode
MethodNotFound Text
errorMsg Maybe Value
forall a. Maybe a
Nothing
          FromServerMessage -> LspM config ()
forall config (m :: * -> *).
MonadLsp config m =>
FromServerMessage -> m ()
sendToClient (FromServerMessage -> LspM config ())
-> FromServerMessage -> LspM config ()
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 m)
    pickHandler :: RegistrationMap t
-> SMethodMap @'FromClient @t (ClientMessageHandler IO t)
-> Maybe (Handler @'FromClient @t IO m)
pickHandler RegistrationMap t
dynHandlerMap SMethodMap @'FromClient @t (ClientMessageHandler IO t)
staticHandler = case (SClientMethod @t m
-> RegistrationMap t
-> Maybe
     (Product
        @(Method 'FromClient t)
        (RegistrationId @t)
        (ClientMessageHandler IO t)
        m)
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 m
m RegistrationMap t
dynHandlerMap, SClientMethod @t m
-> SMethodMap @'FromClient @t (ClientMessageHandler IO t)
-> Maybe (ClientMessageHandler IO t m)
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 m
m SMethodMap @'FromClient @t (ClientMessageHandler IO t)
staticHandler) of
      (Just (Pair RegistrationId @t m
_ (ClientMessageHandler Handler @'FromClient @t IO m
h)), Maybe (ClientMessageHandler IO t m)
_) -> Handler @'FromClient @t IO m
-> Maybe (Handler @'FromClient @t IO m)
forall a. a -> Maybe a
Just Handler @'FromClient @t IO m
h
      (Maybe
  (Product
     @(Method 'FromClient t)
     (RegistrationId @t)
     (ClientMessageHandler IO t)
     m)
Nothing, Just (ClientMessageHandler Handler @'FromClient @t IO m
h)) -> Handler @'FromClient @t IO m
-> Maybe (Handler @'FromClient @t IO m)
forall a. a -> Maybe a
Just Handler @'FromClient @t IO m
h
      (Maybe
  (Product
     @(Method 'FromClient t)
     (RegistrationId @t)
     (ClientMessageHandler IO t)
     m)
Nothing, Maybe (ClientMessageHandler IO t m)
Nothing) -> Maybe (Handler @'FromClient @t IO m)
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 :: LspM config ()
    reportMissingHandler :: LspM config ()
reportMissingHandler
      | SClientMethod @t m -> Bool
forall (f :: From) (t :: MethodType) (m :: Method f t).
SMethod @f @t m -> Bool
isOptionalNotification SClientMethod @t m
m = () -> LspM config ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      | 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 m -> String
forall a. Show a => a -> String
show SClientMethod @t m
m]
          Text -> LspM config ()
forall config (m :: * -> *). MonadLsp config m => Text -> m ()
sendErrorLog Text
errorMsg
    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 :: Message WindowWorkDoneProgressCancel -> LspM config ()
progressCancelHandler :: Message @'FromClient @'Notification 'WindowWorkDoneProgressCancel
-> LspM config ()
progressCancelHandler (NotificationMessage _ _ (WorkDoneProgressCancelParams tid)) = do
  Maybe (IO ())
mact <- ProgressToken -> Map ProgressToken (IO ()) -> Maybe (IO ())
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ProgressToken
tid (Map ProgressToken (IO ()) -> Maybe (IO ()))
-> LspT config IO (Map ProgressToken (IO ()))
-> LspT config IO (Maybe (IO ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (LanguageContextState config -> TVar (Map ProgressToken (IO ())))
-> LspT config IO (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 Maybe (IO ())
mact of
    Maybe (IO ())
Nothing -> () -> LspM config ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just IO ()
cancelAction -> IO () -> LspM config ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> LspM config ()) -> IO () -> LspM config ()
forall a b. (a -> b) -> a -> b
$ IO ()
cancelAction

exitNotificationHandler :: Handler IO Exit
exitNotificationHandler :: Handler @'FromClient @'Notification IO 'Exit
exitNotificationHandler =  \NotificationMessage @'FromClient 'Exit
_ -> do
  String -> String -> IO ()
noticeM String
"lsp.exitNotificationHandler" String
"Got exit, exiting"
  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 :: Message WorkspaceDidChangeConfiguration -> LspM config ()
handleConfigChange :: Message
  @'FromClient @'Notification 'WorkspaceDidChangeConfiguration
-> LspM config ()
handleConfigChange 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
  Either Text ()
res <- (LanguageContextState config -> TVar config)
-> (config -> (Either Text (), config))
-> LspT config IO (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))
 -> LspT config IO (Either Text ()))
-> (config -> (Either Text (), config))
-> LspT config IO (Either Text ())
forall a b. (a -> b) -> a -> b
$ \config
oldConfig -> case config -> Value -> Either Text config
parseConfig config
oldConfig (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) 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
      let msg :: Text
msg = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords
            [String
"lsp:configuration parse error.", NotificationMessage @'FromClient 'WorkspaceDidChangeConfiguration
-> String
forall a. Show a => a -> String
show Message
  @'FromClient @'Notification 'WorkspaceDidChangeConfiguration
NotificationMessage @'FromClient 'WorkspaceDidChangeConfiguration
req, Text -> String
forall a. Show a => a -> String
show Text
err]
      Text -> LspM config ()
forall config (m :: * -> *). MonadLsp config m => Text -> m ()
sendErrorLog Text
msg
    Right () -> () -> LspM config ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

vfsFunc :: (VFS -> b -> (VFS, [String])) -> b -> LspM config ()
vfsFunc :: (VFS -> b -> (VFS, [String])) -> b -> LspM config ()
vfsFunc VFS -> b -> (VFS, [String])
modifyVfs b
req = do
  LspT config IO (LspM config ()) -> LspM config ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (LspT config IO (LspM config ()) -> LspM config ())
-> LspT config IO (LspM config ()) -> LspM config ()
forall a b. (a -> b) -> a -> b
$ (LanguageContextState config -> TVar VFSData)
-> (VFSData -> (LspM config (), VFSData))
-> LspT config IO (LspM config ())
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 -> (LspM config (), VFSData))
 -> LspT config IO (LspM config ()))
-> (VFSData -> (LspM config (), VFSData))
-> LspT config IO (LspM config ())
forall a b. (a -> b) -> a -> b
$ \(VFSData VFS
vfs Map String String
rm) ->
    let (!VFS
vfs', [String]
ls) = VFS -> b -> (VFS, [String])
modifyVfs VFS
vfs b
req
    in (IO () -> LspM config ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> LspM config ()) -> IO () -> LspM config ()
forall a b. (a -> b) -> a -> b
$ (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> String -> IO ()
debugM String
"lsp.vfsFunc") [String]
ls,VFS -> Map String String -> VFSData
VFSData VFS
vfs' Map String String
rm)

-- | 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

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