{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeOperators #-}

module Unison.LSP
  ( spawnLsp,
    LspFormattingConfig (..),
  )
where

import Colog.Core (LogAction (LogAction))
import Colog.Core qualified as Colog
import Compat (onWindows)
import Control.Monad.Reader
import Data.ByteString.Builder.Extra (defaultChunkSize)
import Data.Char (toLower)
import GHC.IO.Exception (ioe_errno)
import Ki qualified
import Language.LSP.Logging qualified as LSP
import Language.LSP.Protocol.Message qualified as Msg
import Language.LSP.Protocol.Types
import Language.LSP.Protocol.Utils.SMethodMap
import Language.LSP.Protocol.Utils.SMethodMap qualified as SMM
import Language.LSP.Server
import Language.LSP.VFS
import Network.Simple.TCP qualified as TCP
import System.Environment (lookupEnv)
import System.IO (hPutStrLn)
import Unison.Codebase
import Unison.Codebase.ProjectPath qualified as PP
import Unison.Codebase.Runtime (Runtime)
import Unison.Debug qualified as Debug
import Unison.LSP.CancelRequest (cancelRequestHandler)
import Unison.LSP.CodeAction (codeActionHandler)
import Unison.LSP.CodeLens (codeLensHandler)
import Unison.LSP.Commands (executeCommandHandler, supportedCommands)
import Unison.LSP.Completion (completionHandler, completionItemResolveHandler)
import Unison.LSP.Configuration qualified as Config
import Unison.LSP.FileAnalysis qualified as Analysis
import Unison.LSP.FoldingRange (foldingRangeRequest)
import Unison.LSP.Formatting (formatDocRequest, formatRangeRequest)
import Unison.LSP.HandlerUtils qualified as Handlers
import Unison.LSP.Hover (hoverHandler)
import Unison.LSP.NotificationHandlers qualified as Notifications
import Unison.LSP.Orphans ()
import Unison.LSP.Types
import Unison.LSP.UCMWorker (ucmWorker)
import Unison.LSP.Util.Signal (Signal)
import Unison.LSP.VFS qualified as VFS
import Unison.Parser.Ann
import Unison.Prelude
import Unison.Symbol
import UnliftIO
import UnliftIO.Foreign (Errno (..), eADDRINUSE)

data LspFormattingConfig = LspFormatEnabled | LspFormatDisabled
  deriving (Int -> LspFormattingConfig -> ShowS
[LspFormattingConfig] -> ShowS
LspFormattingConfig -> String
(Int -> LspFormattingConfig -> ShowS)
-> (LspFormattingConfig -> String)
-> ([LspFormattingConfig] -> ShowS)
-> Show LspFormattingConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LspFormattingConfig -> ShowS
showsPrec :: Int -> LspFormattingConfig -> ShowS
$cshow :: LspFormattingConfig -> String
show :: LspFormattingConfig -> String
$cshowList :: [LspFormattingConfig] -> ShowS
showList :: [LspFormattingConfig] -> ShowS
Show, LspFormattingConfig -> LspFormattingConfig -> Bool
(LspFormattingConfig -> LspFormattingConfig -> Bool)
-> (LspFormattingConfig -> LspFormattingConfig -> Bool)
-> Eq LspFormattingConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LspFormattingConfig -> LspFormattingConfig -> Bool
== :: LspFormattingConfig -> LspFormattingConfig -> Bool
$c/= :: LspFormattingConfig -> LspFormattingConfig -> Bool
/= :: LspFormattingConfig -> LspFormattingConfig -> Bool
Eq)

getLspPort :: IO String
getLspPort :: IO String
getLspPort = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"5757" (Maybe String -> String) -> IO (Maybe String) -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
"UNISON_LSP_PORT"

-- | Spawn an LSP server on the configured port.
spawnLsp ::
  LspFormattingConfig ->
  Codebase IO Symbol Ann ->
  Runtime Symbol ->
  Signal PP.ProjectPathIds ->
  IO ()
spawnLsp :: LspFormattingConfig
-> Codebase IO Symbol Ann
-> Runtime Symbol
-> Signal ProjectPathIds
-> IO ()
spawnLsp LspFormattingConfig
lspFormattingConfig Codebase IO Symbol Ann
codebase Runtime Symbol
runtime Signal ProjectPathIds
signal =
  IO () -> IO ()
ifEnabled (IO () -> IO ()) -> (IO () -> IO ()) -> IO () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ()
forall a. IO a -> IO a
TCP.withSocketsDo (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    String
lspPort <- IO String
getLspPort
    (IOException -> IO ()) -> IO () -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
(IOException -> m a) -> m a -> m a
UnliftIO.handleIO (String -> IOException -> IO ()
handleFailure String
lspPort) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      HostPreference -> String -> ((Socket, SockAddr) -> IO ()) -> IO ()
forall (m :: * -> *) a.
MonadIO m =>
HostPreference -> String -> ((Socket, SockAddr) -> IO ()) -> m a
TCP.serve (String -> HostPreference
TCP.Host String
"127.0.0.1") String
lspPort (((Socket, SockAddr) -> IO ()) -> IO ())
-> ((Socket, SockAddr) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Socket
sock, SockAddr
_sockaddr) -> do
        (Scope -> IO ()) -> IO ()
forall a. (Scope -> IO a) -> IO a
Ki.scoped \Scope
scope -> do
          -- If the socket is closed, reading/writing will throw an exception,
          -- but since the socket is closed, this connection will be shutting down
          -- immediately anyways, so we just ignore it.
          let clientInput :: IO ByteString
clientInput = (SomeException -> IO ByteString) -> IO ByteString -> IO ByteString
forall (m :: * -> *) a.
MonadUnliftIO m =>
(SomeException -> m a) -> m a -> m a
handleAny (\SomeException
_ -> ByteString -> IO ByteString
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
"") do
                -- The server will be in the process of shutting down if the socket is closed,
                -- so just return empty input in the meantime.
                ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
"" (Maybe ByteString -> ByteString)
-> IO (Maybe ByteString) -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Socket -> Int -> IO (Maybe ByteString)
forall (m :: * -> *).
MonadIO m =>
Socket -> Int -> m (Maybe ByteString)
TCP.recv Socket
sock Int
defaultChunkSize
          let clientOutput :: ByteString -> IO ()
clientOutput ByteString
output = (SomeException -> IO ()) -> IO () -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
(SomeException -> m a) -> m a -> m a
handleAny (\SomeException
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) do
                Socket -> ByteString -> IO ()
forall (m :: * -> *). MonadIO m => Socket -> ByteString -> m ()
TCP.sendLazy Socket
sock ByteString
output

          -- currently we have an independent VFS for each LSP client since each client might have
          -- different un-saved state for the same file.
          do
            MVar VFS
vfsVar <- VFS -> IO (MVar VFS)
forall (m :: * -> *) a. MonadIO m => a -> m (MVar a)
newMVar VFS
emptyVFS
            IO Int -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Int -> IO ()) -> IO Int -> IO ()
forall a b. (a -> b) -> a -> b
$ LogAction IO (WithSeverity LspServerLog)
-> LogAction (LspM Config) (WithSeverity LspServerLog)
-> IO ByteString
-> (ByteString -> IO ())
-> ServerDefinition Config
-> IO Int
forall config.
LogAction IO (WithSeverity LspServerLog)
-> LogAction (LspM config) (WithSeverity LspServerLog)
-> IO ByteString
-> (ByteString -> IO ())
-> ServerDefinition config
-> IO Int
runServerWith LogAction IO (WithSeverity LspServerLog)
lspServerLogger LogAction (LspM Config) (WithSeverity LspServerLog)
lspClientLogger IO ByteString
clientInput ByteString -> IO ()
clientOutput (LspFormattingConfig
-> MVar VFS
-> Codebase IO Symbol Ann
-> Runtime Symbol
-> Scope
-> Signal ProjectPathIds
-> ServerDefinition Config
serverDefinition LspFormattingConfig
lspFormattingConfig MVar VFS
vfsVar Codebase IO Symbol Ann
codebase Runtime Symbol
runtime Scope
scope Signal ProjectPathIds
signal)
  where
    handleFailure :: String -> IOException -> IO ()
    handleFailure :: String -> IOException -> IO ()
handleFailure String
lspPort IOException
ioerr =
      case CInt -> Errno
Errno (CInt -> Errno) -> Maybe CInt -> Maybe Errno
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOException -> Maybe CInt
ioe_errno IOException
ioerr of
        Just Errno
errNo
          | Errno
errNo Errno -> Errno -> Bool
forall a. Eq a => a -> a -> Bool
== Errno
eADDRINUSE -> do
              String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Note: Port " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
lspPort String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" is already bound by another process or another UCM. The LSP server will not be started."
        Maybe Errno
_ -> do
          DebugFlag -> String -> IOException -> IO ()
forall a (m :: * -> *).
(Show a, Monad m) =>
DebugFlag -> String -> a -> m ()
Debug.debugM DebugFlag
Debug.LSP String
"LSP Exception" IOException
ioerr
          DebugFlag -> String -> Maybe CInt -> IO ()
forall a (m :: * -> *).
(Show a, Monad m) =>
DebugFlag -> String -> a -> m ()
Debug.debugM DebugFlag
Debug.LSP String
"LSP Errno" (IOException -> Maybe CInt
ioe_errno IOException
ioerr)
          String -> IO ()
putStrLn String
"LSP server failed to start."
    -- Where to send logs that occur before a client connects
    lspServerLogger :: LogAction IO (WithSeverity LspServerLog)
lspServerLogger = Severity
-> (WithSeverity LspServerLog -> Severity)
-> LogAction IO (WithSeverity LspServerLog)
-> LogAction IO (WithSeverity LspServerLog)
forall (m :: * -> *) a.
Applicative m =>
Severity -> (a -> Severity) -> LogAction m a -> LogAction m a
Colog.filterBySeverity Severity
Colog.Error WithSeverity LspServerLog -> Severity
forall msg. WithSeverity msg -> Severity
Colog.getSeverity (LogAction IO (WithSeverity LspServerLog)
 -> LogAction IO (WithSeverity LspServerLog))
-> LogAction IO (WithSeverity LspServerLog)
-> LogAction IO (WithSeverity LspServerLog)
forall a b. (a -> b) -> a -> b
$ (WithSeverity LspServerLog -> WithSeverity Text)
-> LogAction IO (WithSeverity Text)
-> LogAction IO (WithSeverity LspServerLog)
forall a b (m :: * -> *).
(a -> b) -> LogAction m b -> LogAction m a
Colog.cmap ((LspServerLog -> Text)
-> WithSeverity LspServerLog -> WithSeverity Text
forall a b. (a -> b) -> WithSeverity a -> WithSeverity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LspServerLog -> Text
forall a. Show a => a -> Text
tShow) ((WithSeverity Text -> IO ()) -> LogAction IO (WithSeverity Text)
forall (m :: * -> *) msg. (msg -> m ()) -> LogAction m msg
LogAction WithSeverity Text -> IO ()
forall a. Show a => a -> IO ()
print)
    -- Where to send logs that occur after a client connects
    lspClientLogger :: LogAction (LspM Config) (WithSeverity LspServerLog)
lspClientLogger = (WithSeverity LspServerLog -> WithSeverity Text)
-> LogAction (LspM Config) (WithSeverity Text)
-> LogAction (LspM Config) (WithSeverity LspServerLog)
forall a b (m :: * -> *).
(a -> b) -> LogAction m b -> LogAction m a
Colog.cmap ((LspServerLog -> Text)
-> WithSeverity LspServerLog -> WithSeverity Text
forall a b. (a -> b) -> WithSeverity a -> WithSeverity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LspServerLog -> Text
forall a. Show a => a -> Text
tShow) LogAction (LspM Config) (WithSeverity Text)
forall c (m :: * -> *).
MonadLsp c m =>
LogAction m (WithSeverity Text)
LSP.defaultClientLogger
    ifEnabled :: IO () -> IO ()
    ifEnabled :: IO () -> IO ()
ifEnabled IO ()
runServer = do
      -- Default LSP to disabled on Windows unless explicitly enabled
      String -> IO (Maybe String)
lookupEnv String
"UNISON_LSP_ENABLED" IO (Maybe String) -> (Maybe String -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just ((Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Char -> Char
toLower -> String
"false") -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Just ((Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Char -> Char
toLower -> String
"true") -> IO ()
runServer
        Just String
x -> Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Invalid value for UNISON_LSP_ENABLED, expected 'true' or 'false' but found: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
x
        Maybe String
Nothing -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
onWindows) IO ()
runServer

serverDefinition ::
  LspFormattingConfig ->
  MVar VFS ->
  Codebase IO Symbol Ann ->
  Runtime Symbol ->
  Ki.Scope ->
  Signal PP.ProjectPathIds ->
  ServerDefinition Config
serverDefinition :: LspFormattingConfig
-> MVar VFS
-> Codebase IO Symbol Ann
-> Runtime Symbol
-> Scope
-> Signal ProjectPathIds
-> ServerDefinition Config
serverDefinition LspFormattingConfig
lspFormattingConfig MVar VFS
vfsVar Codebase IO Symbol Ann
codebase Runtime Symbol
runtime Scope
scope Signal ProjectPathIds
signal =
  ServerDefinition
    { defaultConfig :: Config
defaultConfig = Config
defaultLSPConfig,
      configSection :: Text
configSection = Text
"unison",
      parseConfig :: Config -> Value -> Either Text Config
parseConfig = Config -> Value -> Either Text Config
Config.parseConfig,
      onConfigChange :: Config -> Lsp ()
onConfigChange = Config -> Lsp ()
forall (m :: * -> *). Applicative m => Config -> m ()
Config.updateConfig,
      doInitialize :: LanguageContextEnv Config
-> TMessage 'Method_Initialize -> IO (Either ResponseError Env)
doInitialize = MVar VFS
-> Codebase IO Symbol Ann
-> Runtime Symbol
-> Scope
-> Signal ProjectPathIds
-> LanguageContextEnv Config
-> TMessage 'Method_Initialize
-> IO (Either ResponseError Env)
lspDoInitialize MVar VFS
vfsVar Codebase IO Symbol Ann
codebase Runtime Symbol
runtime Scope
scope Signal ProjectPathIds
signal,
      staticHandlers :: ClientCapabilities -> Handlers Lsp
staticHandlers = LspFormattingConfig -> ClientCapabilities -> Handlers Lsp
lspStaticHandlers LspFormattingConfig
lspFormattingConfig,
      interpretHandler :: Env -> Lsp <~> IO
interpretHandler = Env -> Lsp <~> IO
lspInterpretHandler,
      options :: Options
options = Options
lspOptions
    }

-- | Initialize any context needed by the LSP server
lspDoInitialize ::
  MVar VFS ->
  Codebase IO Symbol Ann ->
  Runtime Symbol ->
  Ki.Scope ->
  Signal PP.ProjectPathIds ->
  LanguageContextEnv Config ->
  Msg.TMessage 'Msg.Method_Initialize ->
  IO (Either Msg.ResponseError Env)
lspDoInitialize :: MVar VFS
-> Codebase IO Symbol Ann
-> Runtime Symbol
-> Scope
-> Signal ProjectPathIds
-> LanguageContextEnv Config
-> TMessage 'Method_Initialize
-> IO (Either ResponseError Env)
lspDoInitialize MVar VFS
vfsVar Codebase IO Symbol Ann
codebase Runtime Symbol
runtime Scope
scope Signal ProjectPathIds
signal LanguageContextEnv Config
lspContext TMessage 'Method_Initialize
_initMsg = do
  TVar (Map Uri (TMVar FileAnalysis))
checkedFilesVar <- Map Uri (TMVar FileAnalysis)
-> IO (TVar (Map Uri (TMVar FileAnalysis)))
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Map Uri (TMVar FileAnalysis)
forall a. Monoid a => a
mempty
  TVar (Set Uri)
dirtyFilesVar <- Set Uri -> IO (TVar (Set Uri))
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Set Uri
forall a. Monoid a => a
mempty
  TMVar PrettyPrintEnvDecl
ppedCacheVar <- IO (TMVar PrettyPrintEnvDecl)
forall (m :: * -> *) a. MonadIO m => m (TMVar a)
newEmptyTMVarIO
  TMVar Names
currentNamesCacheVar <- IO (TMVar Names)
forall (m :: * -> *) a. MonadIO m => m (TMVar a)
newEmptyTMVarIO
  TMVar ProjectPath
currentPathCacheVar <- IO (TMVar ProjectPath)
forall (m :: * -> *) a. MonadIO m => m (TMVar a)
newEmptyTMVarIO
  TVar (Map (Int32 |? Text) (IO ()))
cancellationMapVar <- Map (Int32 |? Text) (IO ())
-> IO (TVar (Map (Int32 |? Text) (IO ())))
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Map (Int32 |? Text) (IO ())
forall a. Monoid a => a
mempty
  TMVar CompletionTree
completionsVar <- IO (TMVar CompletionTree)
forall (m :: * -> *) a. MonadIO m => m (TMVar a)
newEmptyTMVarIO
  TMVar (NameSearch Transaction)
nameSearchCacheVar <- IO (TMVar (NameSearch Transaction))
forall (m :: * -> *) a. MonadIO m => m (TMVar a)
newEmptyTMVarIO
  let env :: Env
env =
        Env
          { $sel:ppedCache:Env :: IO PrettyPrintEnvDecl
ppedCache = STM PrettyPrintEnvDecl -> IO PrettyPrintEnvDecl
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM PrettyPrintEnvDecl -> IO PrettyPrintEnvDecl)
-> STM PrettyPrintEnvDecl -> IO PrettyPrintEnvDecl
forall a b. (a -> b) -> a -> b
$ TMVar PrettyPrintEnvDecl -> STM PrettyPrintEnvDecl
forall a. TMVar a -> STM a
readTMVar TMVar PrettyPrintEnvDecl
ppedCacheVar,
            $sel:currentNamesCache:Env :: IO Names
currentNamesCache = STM Names -> IO Names
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM Names -> IO Names) -> STM Names -> IO Names
forall a b. (a -> b) -> a -> b
$ TMVar Names -> STM Names
forall a. TMVar a -> STM a
readTMVar TMVar Names
currentNamesCacheVar,
            $sel:currentProjectPathCache:Env :: IO ProjectPath
currentProjectPathCache = STM ProjectPath -> IO ProjectPath
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM ProjectPath -> IO ProjectPath)
-> STM ProjectPath -> IO ProjectPath
forall a b. (a -> b) -> a -> b
$ TMVar ProjectPath -> STM ProjectPath
forall a. TMVar a -> STM a
readTMVar TMVar ProjectPath
currentPathCacheVar,
            $sel:nameSearchCache:Env :: IO (NameSearch Transaction)
nameSearchCache = STM (NameSearch Transaction) -> IO (NameSearch Transaction)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (NameSearch Transaction) -> IO (NameSearch Transaction))
-> STM (NameSearch Transaction) -> IO (NameSearch Transaction)
forall a b. (a -> b) -> a -> b
$ TMVar (NameSearch Transaction) -> STM (NameSearch Transaction)
forall a. TMVar a -> STM a
readTMVar TMVar (NameSearch Transaction)
nameSearchCacheVar,
            MVar VFS
TVar (Map (Int32 |? Text) (IO ()))
TVar (Map Uri (TMVar FileAnalysis))
TVar (Set Uri)
Scope
LanguageContextEnv Config
TMVar CompletionTree
Runtime Symbol
Codebase IO Symbol Ann
vfsVar :: MVar VFS
codebase :: Codebase IO Symbol Ann
runtime :: Runtime Symbol
scope :: Scope
lspContext :: LanguageContextEnv Config
checkedFilesVar :: TVar (Map Uri (TMVar FileAnalysis))
dirtyFilesVar :: TVar (Set Uri)
cancellationMapVar :: TVar (Map (Int32 |? Text) (IO ()))
completionsVar :: TMVar CompletionTree
$sel:lspContext:Env :: LanguageContextEnv Config
$sel:codebase:Env :: Codebase IO Symbol Ann
$sel:vfsVar:Env :: MVar VFS
$sel:runtime:Env :: Runtime Symbol
$sel:checkedFilesVar:Env :: TVar (Map Uri (TMVar FileAnalysis))
$sel:dirtyFilesVar:Env :: TVar (Set Uri)
$sel:cancellationMapVar:Env :: TVar (Map (Int32 |? Text) (IO ()))
$sel:completionsVar:Env :: TMVar CompletionTree
$sel:scope:Env :: Scope
..
          }
  let lspToIO :: Lsp () -> IO ()
lspToIO = (ReaderT (LanguageContextEnv Config) IO ()
 -> LanguageContextEnv Config -> IO ())
-> LanguageContextEnv Config
-> ReaderT (LanguageContextEnv Config) IO ()
-> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT (LanguageContextEnv Config) IO ()
-> LanguageContextEnv Config -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT LanguageContextEnv Config
lspContext (ReaderT (LanguageContextEnv Config) IO () -> IO ())
-> (Lsp () -> ReaderT (LanguageContextEnv Config) IO ())
-> Lsp ()
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LspT Config IO () -> ReaderT (LanguageContextEnv Config) IO ()
forall config (m :: * -> *) a.
LspT config m a -> ReaderT (LanguageContextEnv config) m a
unLspT (LspT Config IO () -> ReaderT (LanguageContextEnv Config) IO ())
-> (Lsp () -> LspT Config IO ())
-> Lsp ()
-> ReaderT (LanguageContextEnv Config) IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ReaderT Env (LspM Config) () -> Env -> LspT Config IO ())
-> Env -> ReaderT Env (LspM Config) () -> LspT Config IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT Env (LspM Config) () -> Env -> LspT Config IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT Env
env (ReaderT Env (LspM Config) () -> LspT Config IO ())
-> (Lsp () -> ReaderT Env (LspM Config) ())
-> Lsp ()
-> LspT Config IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lsp () -> ReaderT Env (LspM Config) ()
forall a. Lsp a -> ReaderT Env (LspM Config) a
runLspM
  Scope -> IO () -> IO (Thread ())
forall a. Scope -> IO a -> IO (Thread a)
Ki.fork Scope
scope (Lsp () -> IO ()
lspToIO Lsp ()
Analysis.fileAnalysisWorker)
  Scope -> IO () -> IO (Thread ())
forall a. Scope -> IO a -> IO (Thread a)
Ki.fork Scope
scope (Lsp () -> IO ()
lspToIO (Lsp () -> IO ()) -> Lsp () -> IO ()
forall a b. (a -> b) -> a -> b
$ TMVar PrettyPrintEnvDecl
-> TMVar Names
-> TMVar (NameSearch Transaction)
-> TMVar ProjectPath
-> Signal ProjectPathIds
-> Lsp ()
ucmWorker TMVar PrettyPrintEnvDecl
ppedCacheVar TMVar Names
currentNamesCacheVar TMVar (NameSearch Transaction)
nameSearchCacheVar TMVar ProjectPath
currentPathCacheVar Signal ProjectPathIds
signal)
  pure $ Env -> Either ResponseError Env
forall a b. b -> Either a b
Right (Env -> Either ResponseError Env)
-> Env -> Either ResponseError Env
forall a b. (a -> b) -> a -> b
$ Env
env

-- | LSP request handlers that don't register/unregister dynamically
lspStaticHandlers :: LspFormattingConfig -> ClientCapabilities -> Handlers Lsp
lspStaticHandlers :: LspFormattingConfig -> ClientCapabilities -> Handlers Lsp
lspStaticHandlers LspFormattingConfig
lspFormattingConfig ClientCapabilities
_capabilities =
  Handlers
    { reqHandlers :: SMethodMap (ClientMessageHandler Lsp 'Request)
reqHandlers = LspFormattingConfig
-> SMethodMap (ClientMessageHandler Lsp 'Request)
lspRequestHandlers LspFormattingConfig
lspFormattingConfig,
      notHandlers :: SMethodMap (ClientMessageHandler Lsp 'Notification)
notHandlers = SMethodMap (ClientMessageHandler Lsp 'Notification)
lspNotificationHandlers
    }

-- | LSP request handlers
lspRequestHandlers :: LspFormattingConfig -> SMethodMap (ClientMessageHandler Lsp 'Msg.Request)
lspRequestHandlers :: LspFormattingConfig
-> SMethodMap (ClientMessageHandler Lsp 'Request)
lspRequestHandlers LspFormattingConfig
lspFormattingConfig =
  SMethodMap (ClientMessageHandler Lsp 'Request)
forall a. Monoid a => a
mempty
    SMethodMap (ClientMessageHandler Lsp 'Request)
-> (SMethodMap (ClientMessageHandler Lsp 'Request)
    -> SMethodMap (ClientMessageHandler Lsp 'Request))
-> SMethodMap (ClientMessageHandler Lsp 'Request)
forall a b. a -> (a -> b) -> b
& SMethod 'Method_TextDocumentHover
-> ClientMessageHandler Lsp 'Request 'Method_TextDocumentHover
-> SMethodMap (ClientMessageHandler Lsp 'Request)
-> SMethodMap (ClientMessageHandler Lsp 'Request)
forall {f :: MessageDirection} {t :: MessageKind} (a :: Method f t)
       (v :: Method f t -> *).
SMethod a -> v a -> SMethodMap v -> SMethodMap v
SMM.insert SMethod 'Method_TextDocumentHover
Msg.SMethod_TextDocumentHover ((TRequestMessage 'Method_TextDocumentHover
 -> (Either ResponseError (MessageResult 'Method_TextDocumentHover)
     -> Lsp ())
 -> Lsp ())
-> ClientMessageHandler Lsp 'Request 'Method_TextDocumentHover
forall (m :: Method 'ClientToServer 'Request).
(Show (TRequestMessage m), Show (TResponseMessage m),
 Show (MessageResult m)) =>
(TRequestMessage m
 -> (Either ResponseError (MessageResult m) -> Lsp ()) -> Lsp ())
-> ClientMessageHandler Lsp 'Request m
mkHandler TRequestMessage 'Method_TextDocumentHover
-> (Either ResponseError (MessageResult 'Method_TextDocumentHover)
    -> Lsp ())
-> Lsp ()
hoverHandler)
    SMethodMap (ClientMessageHandler Lsp 'Request)
-> (SMethodMap (ClientMessageHandler Lsp 'Request)
    -> SMethodMap (ClientMessageHandler Lsp 'Request))
-> SMethodMap (ClientMessageHandler Lsp 'Request)
forall a b. a -> (a -> b) -> b
& SMethod 'Method_TextDocumentCodeAction
-> ClientMessageHandler Lsp 'Request 'Method_TextDocumentCodeAction
-> SMethodMap (ClientMessageHandler Lsp 'Request)
-> SMethodMap (ClientMessageHandler Lsp 'Request)
forall {f :: MessageDirection} {t :: MessageKind} (a :: Method f t)
       (v :: Method f t -> *).
SMethod a -> v a -> SMethodMap v -> SMethodMap v
SMM.insert SMethod 'Method_TextDocumentCodeAction
Msg.SMethod_TextDocumentCodeAction ((TRequestMessage 'Method_TextDocumentCodeAction
 -> (Either
       ResponseError (MessageResult 'Method_TextDocumentCodeAction)
     -> Lsp ())
 -> Lsp ())
-> ClientMessageHandler Lsp 'Request 'Method_TextDocumentCodeAction
forall (m :: Method 'ClientToServer 'Request).
(Show (TRequestMessage m), Show (TResponseMessage m),
 Show (MessageResult m)) =>
(TRequestMessage m
 -> (Either ResponseError (MessageResult m) -> Lsp ()) -> Lsp ())
-> ClientMessageHandler Lsp 'Request m
mkHandler TRequestMessage 'Method_TextDocumentCodeAction
-> (Either
      ResponseError (MessageResult 'Method_TextDocumentCodeAction)
    -> Lsp ())
-> Lsp ()
codeActionHandler)
    SMethodMap (ClientMessageHandler Lsp 'Request)
-> (SMethodMap (ClientMessageHandler Lsp 'Request)
    -> SMethodMap (ClientMessageHandler Lsp 'Request))
-> SMethodMap (ClientMessageHandler Lsp 'Request)
forall a b. a -> (a -> b) -> b
& SMethod 'Method_TextDocumentCodeLens
-> ClientMessageHandler Lsp 'Request 'Method_TextDocumentCodeLens
-> SMethodMap (ClientMessageHandler Lsp 'Request)
-> SMethodMap (ClientMessageHandler Lsp 'Request)
forall {f :: MessageDirection} {t :: MessageKind} (a :: Method f t)
       (v :: Method f t -> *).
SMethod a -> v a -> SMethodMap v -> SMethodMap v
SMM.insert SMethod 'Method_TextDocumentCodeLens
Msg.SMethod_TextDocumentCodeLens ((TRequestMessage 'Method_TextDocumentCodeLens
 -> (Either
       ResponseError (MessageResult 'Method_TextDocumentCodeLens)
     -> Lsp ())
 -> Lsp ())
-> ClientMessageHandler Lsp 'Request 'Method_TextDocumentCodeLens
forall (m :: Method 'ClientToServer 'Request).
(Show (TRequestMessage m), Show (TResponseMessage m),
 Show (MessageResult m)) =>
(TRequestMessage m
 -> (Either ResponseError (MessageResult m) -> Lsp ()) -> Lsp ())
-> ClientMessageHandler Lsp 'Request m
mkHandler TRequestMessage 'Method_TextDocumentCodeLens
-> (Either ResponseError ([CodeLens] |? Null) -> Lsp ()) -> Lsp ()
TRequestMessage 'Method_TextDocumentCodeLens
-> (Either
      ResponseError (MessageResult 'Method_TextDocumentCodeLens)
    -> Lsp ())
-> Lsp ()
codeLensHandler)
    SMethodMap (ClientMessageHandler Lsp 'Request)
-> (SMethodMap (ClientMessageHandler Lsp 'Request)
    -> SMethodMap (ClientMessageHandler Lsp 'Request))
-> SMethodMap (ClientMessageHandler Lsp 'Request)
forall a b. a -> (a -> b) -> b
& SMethod 'Method_WorkspaceExecuteCommand
-> ClientMessageHandler
     Lsp 'Request 'Method_WorkspaceExecuteCommand
-> SMethodMap (ClientMessageHandler Lsp 'Request)
-> SMethodMap (ClientMessageHandler Lsp 'Request)
forall {f :: MessageDirection} {t :: MessageKind} (a :: Method f t)
       (v :: Method f t -> *).
SMethod a -> v a -> SMethodMap v -> SMethodMap v
SMM.insert SMethod 'Method_WorkspaceExecuteCommand
Msg.SMethod_WorkspaceExecuteCommand ((TRequestMessage 'Method_WorkspaceExecuteCommand
 -> (Either
       ResponseError (MessageResult 'Method_WorkspaceExecuteCommand)
     -> Lsp ())
 -> Lsp ())
-> ClientMessageHandler
     Lsp 'Request 'Method_WorkspaceExecuteCommand
forall (m :: Method 'ClientToServer 'Request).
(Show (TRequestMessage m), Show (TResponseMessage m),
 Show (MessageResult m)) =>
(TRequestMessage m
 -> (Either ResponseError (MessageResult m) -> Lsp ()) -> Lsp ())
-> ClientMessageHandler Lsp 'Request m
mkHandler TRequestMessage 'Method_WorkspaceExecuteCommand
-> (Either ResponseError (Value |? Null) -> Lsp ()) -> Lsp ()
TRequestMessage 'Method_WorkspaceExecuteCommand
-> (Either
      ResponseError (MessageResult 'Method_WorkspaceExecuteCommand)
    -> Lsp ())
-> Lsp ()
executeCommandHandler)
    SMethodMap (ClientMessageHandler Lsp 'Request)
-> (SMethodMap (ClientMessageHandler Lsp 'Request)
    -> SMethodMap (ClientMessageHandler Lsp 'Request))
-> SMethodMap (ClientMessageHandler Lsp 'Request)
forall a b. a -> (a -> b) -> b
& SMethod 'Method_TextDocumentFoldingRange
-> ClientMessageHandler
     Lsp 'Request 'Method_TextDocumentFoldingRange
-> SMethodMap (ClientMessageHandler Lsp 'Request)
-> SMethodMap (ClientMessageHandler Lsp 'Request)
forall {f :: MessageDirection} {t :: MessageKind} (a :: Method f t)
       (v :: Method f t -> *).
SMethod a -> v a -> SMethodMap v -> SMethodMap v
SMM.insert SMethod 'Method_TextDocumentFoldingRange
Msg.SMethod_TextDocumentFoldingRange ((TRequestMessage 'Method_TextDocumentFoldingRange
 -> (Either
       ResponseError (MessageResult 'Method_TextDocumentFoldingRange)
     -> Lsp ())
 -> Lsp ())
-> ClientMessageHandler
     Lsp 'Request 'Method_TextDocumentFoldingRange
forall (m :: Method 'ClientToServer 'Request).
(Show (TRequestMessage m), Show (TResponseMessage m),
 Show (MessageResult m)) =>
(TRequestMessage m
 -> (Either ResponseError (MessageResult m) -> Lsp ()) -> Lsp ())
-> ClientMessageHandler Lsp 'Request m
mkHandler TRequestMessage 'Method_TextDocumentFoldingRange
-> (Either
      ResponseError (MessageResult 'Method_TextDocumentFoldingRange)
    -> Lsp ())
-> Lsp ()
foldingRangeRequest)
    SMethodMap (ClientMessageHandler Lsp 'Request)
-> (SMethodMap (ClientMessageHandler Lsp 'Request)
    -> SMethodMap (ClientMessageHandler Lsp 'Request))
-> SMethodMap (ClientMessageHandler Lsp 'Request)
forall a b. a -> (a -> b) -> b
& SMethod 'Method_TextDocumentCompletion
-> ClientMessageHandler Lsp 'Request 'Method_TextDocumentCompletion
-> SMethodMap (ClientMessageHandler Lsp 'Request)
-> SMethodMap (ClientMessageHandler Lsp 'Request)
forall {f :: MessageDirection} {t :: MessageKind} (a :: Method f t)
       (v :: Method f t -> *).
SMethod a -> v a -> SMethodMap v -> SMethodMap v
SMM.insert SMethod 'Method_TextDocumentCompletion
Msg.SMethod_TextDocumentCompletion ((TRequestMessage 'Method_TextDocumentCompletion
 -> (Either
       ResponseError (MessageResult 'Method_TextDocumentCompletion)
     -> Lsp ())
 -> Lsp ())
-> ClientMessageHandler Lsp 'Request 'Method_TextDocumentCompletion
forall (m :: Method 'ClientToServer 'Request).
(Show (TRequestMessage m), Show (TResponseMessage m),
 Show (MessageResult m)) =>
(TRequestMessage m
 -> (Either ResponseError (MessageResult m) -> Lsp ()) -> Lsp ())
-> ClientMessageHandler Lsp 'Request m
mkHandler TRequestMessage 'Method_TextDocumentCompletion
-> (Either
      ResponseError (MessageResult 'Method_TextDocumentCompletion)
    -> Lsp ())
-> Lsp ()
completionHandler)
    SMethodMap (ClientMessageHandler Lsp 'Request)
-> (SMethodMap (ClientMessageHandler Lsp 'Request)
    -> SMethodMap (ClientMessageHandler Lsp 'Request))
-> SMethodMap (ClientMessageHandler Lsp 'Request)
forall a b. a -> (a -> b) -> b
& SMethod 'Method_CompletionItemResolve
-> ClientMessageHandler Lsp 'Request 'Method_CompletionItemResolve
-> SMethodMap (ClientMessageHandler Lsp 'Request)
-> SMethodMap (ClientMessageHandler Lsp 'Request)
forall {f :: MessageDirection} {t :: MessageKind} (a :: Method f t)
       (v :: Method f t -> *).
SMethod a -> v a -> SMethodMap v -> SMethodMap v
SMM.insert SMethod 'Method_CompletionItemResolve
Msg.SMethod_CompletionItemResolve ((TRequestMessage 'Method_CompletionItemResolve
 -> (Either
       ResponseError (MessageResult 'Method_CompletionItemResolve)
     -> Lsp ())
 -> Lsp ())
-> ClientMessageHandler Lsp 'Request 'Method_CompletionItemResolve
forall (m :: Method 'ClientToServer 'Request).
(Show (TRequestMessage m), Show (TResponseMessage m),
 Show (MessageResult m)) =>
(TRequestMessage m
 -> (Either ResponseError (MessageResult m) -> Lsp ()) -> Lsp ())
-> ClientMessageHandler Lsp 'Request m
mkHandler TRequestMessage 'Method_CompletionItemResolve
-> (Either ResponseError CompletionItem -> Lsp ()) -> Lsp ()
TRequestMessage 'Method_CompletionItemResolve
-> (Either
      ResponseError (MessageResult 'Method_CompletionItemResolve)
    -> Lsp ())
-> Lsp ()
completionItemResolveHandler)
    SMethodMap (ClientMessageHandler Lsp 'Request)
-> (SMethodMap (ClientMessageHandler Lsp 'Request)
    -> SMethodMap (ClientMessageHandler Lsp 'Request))
-> SMethodMap (ClientMessageHandler Lsp 'Request)
forall a b. a -> (a -> b) -> b
& SMethodMap (ClientMessageHandler Lsp 'Request)
-> SMethodMap (ClientMessageHandler Lsp 'Request)
addFormattingHandlers
  where
    addFormattingHandlers :: SMethodMap (ClientMessageHandler Lsp 'Request)
-> SMethodMap (ClientMessageHandler Lsp 'Request)
addFormattingHandlers SMethodMap (ClientMessageHandler Lsp 'Request)
handlers =
      case LspFormattingConfig
lspFormattingConfig of
        LspFormattingConfig
LspFormatEnabled ->
          SMethodMap (ClientMessageHandler Lsp 'Request)
handlers
            SMethodMap (ClientMessageHandler Lsp 'Request)
-> (SMethodMap (ClientMessageHandler Lsp 'Request)
    -> SMethodMap (ClientMessageHandler Lsp 'Request))
-> SMethodMap (ClientMessageHandler Lsp 'Request)
forall a b. a -> (a -> b) -> b
& SMethod 'Method_TextDocumentFormatting
-> ClientMessageHandler Lsp 'Request 'Method_TextDocumentFormatting
-> SMethodMap (ClientMessageHandler Lsp 'Request)
-> SMethodMap (ClientMessageHandler Lsp 'Request)
forall {f :: MessageDirection} {t :: MessageKind} (a :: Method f t)
       (v :: Method f t -> *).
SMethod a -> v a -> SMethodMap v -> SMethodMap v
SMM.insert SMethod 'Method_TextDocumentFormatting
Msg.SMethod_TextDocumentFormatting ((TRequestMessage 'Method_TextDocumentFormatting
 -> (Either
       ResponseError (MessageResult 'Method_TextDocumentFormatting)
     -> Lsp ())
 -> Lsp ())
-> ClientMessageHandler Lsp 'Request 'Method_TextDocumentFormatting
forall (m :: Method 'ClientToServer 'Request).
(Show (TRequestMessage m), Show (TResponseMessage m),
 Show (MessageResult m)) =>
(TRequestMessage m
 -> (Either ResponseError (MessageResult m) -> Lsp ()) -> Lsp ())
-> ClientMessageHandler Lsp 'Request m
mkHandler TRequestMessage 'Method_TextDocumentFormatting
-> (Either
      ResponseError (MessageResult 'Method_TextDocumentFormatting)
    -> Lsp ())
-> Lsp ()
formatDocRequest)
            SMethodMap (ClientMessageHandler Lsp 'Request)
-> (SMethodMap (ClientMessageHandler Lsp 'Request)
    -> SMethodMap (ClientMessageHandler Lsp 'Request))
-> SMethodMap (ClientMessageHandler Lsp 'Request)
forall a b. a -> (a -> b) -> b
& SMethod 'Method_TextDocumentRangeFormatting
-> ClientMessageHandler
     Lsp 'Request 'Method_TextDocumentRangeFormatting
-> SMethodMap (ClientMessageHandler Lsp 'Request)
-> SMethodMap (ClientMessageHandler Lsp 'Request)
forall {f :: MessageDirection} {t :: MessageKind} (a :: Method f t)
       (v :: Method f t -> *).
SMethod a -> v a -> SMethodMap v -> SMethodMap v
SMM.insert SMethod 'Method_TextDocumentRangeFormatting
Msg.SMethod_TextDocumentRangeFormatting ((TRequestMessage 'Method_TextDocumentRangeFormatting
 -> (Either
       ResponseError (MessageResult 'Method_TextDocumentRangeFormatting)
     -> Lsp ())
 -> Lsp ())
-> ClientMessageHandler
     Lsp 'Request 'Method_TextDocumentRangeFormatting
forall (m :: Method 'ClientToServer 'Request).
(Show (TRequestMessage m), Show (TResponseMessage m),
 Show (MessageResult m)) =>
(TRequestMessage m
 -> (Either ResponseError (MessageResult m) -> Lsp ()) -> Lsp ())
-> ClientMessageHandler Lsp 'Request m
mkHandler TRequestMessage 'Method_TextDocumentRangeFormatting
-> (Either
      ResponseError (MessageResult 'Method_TextDocumentRangeFormatting)
    -> Lsp ())
-> Lsp ()
formatRangeRequest)
        LspFormattingConfig
LspFormatDisabled -> SMethodMap (ClientMessageHandler Lsp 'Request)
handlers
    defaultTimeout :: Int
defaultTimeout = Int
10_000 -- 10s
    mkHandler ::
      forall m.
      (Show (Msg.TRequestMessage m), Show (Msg.TResponseMessage m), Show (Msg.MessageResult m)) =>
      ( ( Msg.TRequestMessage m ->
          (Either Msg.ResponseError (Msg.MessageResult m) -> Lsp ()) ->
          Lsp ()
        ) ->
        ClientMessageHandler Lsp 'Msg.Request m
      )
    mkHandler :: forall (m :: Method 'ClientToServer 'Request).
(Show (TRequestMessage m), Show (TResponseMessage m),
 Show (MessageResult m)) =>
(TRequestMessage m
 -> (Either ResponseError (MessageResult m) -> Lsp ()) -> Lsp ())
-> ClientMessageHandler Lsp 'Request m
mkHandler TRequestMessage m
-> (Either ResponseError (MessageResult m) -> Lsp ()) -> Lsp ()
h =
      TRequestMessage m
-> (Either ResponseError (MessageResult m) -> Lsp ()) -> Lsp ()
h
        (TRequestMessage m
 -> (Either ResponseError (MessageResult m) -> Lsp ()) -> Lsp ())
-> ((TRequestMessage m
     -> (Either ResponseError (MessageResult m) -> Lsp ()) -> Lsp ())
    -> TRequestMessage m
    -> (Either ResponseError (MessageResult m) -> Lsp ())
    -> Lsp ())
-> TRequestMessage m
-> (Either ResponseError (MessageResult m) -> Lsp ())
-> Lsp ()
forall a b. a -> (a -> b) -> b
& Maybe Int
-> (TRequestMessage m
    -> (Either ResponseError (MessageResult m) -> Lsp ()) -> Lsp ())
-> TRequestMessage m
-> (Either ResponseError (MessageResult m) -> Lsp ())
-> Lsp ()
forall {f :: MessageDirection} (message :: Method f 'Request).
Maybe Int
-> (TRequestMessage message
    -> (Either ResponseError (MessageResult message) -> Lsp ())
    -> Lsp ())
-> TRequestMessage message
-> (Either ResponseError (MessageResult message) -> Lsp ())
-> Lsp ()
Handlers.withCancellation (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
defaultTimeout)
        (TRequestMessage m
 -> (Either ResponseError (MessageResult m) -> Lsp ()) -> Lsp ())
-> ((TRequestMessage m
     -> (Either ResponseError (MessageResult m) -> Lsp ()) -> Lsp ())
    -> TRequestMessage m
    -> (Either ResponseError (MessageResult m) -> Lsp ())
    -> Lsp ())
-> TRequestMessage m
-> (Either ResponseError (MessageResult m) -> Lsp ())
-> Lsp ()
forall a b. a -> (a -> b) -> b
& (TRequestMessage m
 -> (Either ResponseError (MessageResult m) -> Lsp ()) -> Lsp ())
-> TRequestMessage m
-> (Either ResponseError (MessageResult m) -> Lsp ())
-> Lsp ()
forall {f :: MessageDirection} (message :: Method f 'Request).
(Show (TRequestMessage message), Show (MessageResult message)) =>
(TRequestMessage message
 -> (Either ResponseError (MessageResult message) -> Lsp ())
 -> Lsp ())
-> TRequestMessage message
-> (Either ResponseError (MessageResult message) -> Lsp ())
-> Lsp ()
Handlers.withDebugging
        (TRequestMessage m
 -> (Either ResponseError (MessageResult m) -> Lsp ()) -> Lsp ())
-> ((TRequestMessage m
     -> (Either ResponseError (MessageResult m) -> Lsp ()) -> Lsp ())
    -> ClientMessageHandler Lsp 'Request m)
-> ClientMessageHandler Lsp 'Request m
forall a b. a -> (a -> b) -> b
& Handler Lsp m -> ClientMessageHandler Lsp 'Request m
(TRequestMessage m
 -> (Either ResponseError (MessageResult m) -> Lsp ()) -> Lsp ())
-> ClientMessageHandler Lsp 'Request m
forall (f :: * -> *) (t :: MessageKind)
       (m :: Method 'ClientToServer t).
Handler f m -> ClientMessageHandler f t m
ClientMessageHandler

-- | LSP notification handlers
lspNotificationHandlers :: SMethodMap (ClientMessageHandler Lsp 'Msg.Notification)
lspNotificationHandlers :: SMethodMap (ClientMessageHandler Lsp 'Notification)
lspNotificationHandlers =
  SMethodMap (ClientMessageHandler Lsp 'Notification)
forall a. Monoid a => a
mempty
    SMethodMap (ClientMessageHandler Lsp 'Notification)
-> (SMethodMap (ClientMessageHandler Lsp 'Notification)
    -> SMethodMap (ClientMessageHandler Lsp 'Notification))
-> SMethodMap (ClientMessageHandler Lsp 'Notification)
forall a b. a -> (a -> b) -> b
& SMethod 'Method_TextDocumentDidOpen
-> ClientMessageHandler
     Lsp 'Notification 'Method_TextDocumentDidOpen
-> SMethodMap (ClientMessageHandler Lsp 'Notification)
-> SMethodMap (ClientMessageHandler Lsp 'Notification)
forall {f :: MessageDirection} {t :: MessageKind} (a :: Method f t)
       (v :: Method f t -> *).
SMethod a -> v a -> SMethodMap v -> SMethodMap v
SMM.insert SMethod 'Method_TextDocumentDidOpen
Msg.SMethod_TextDocumentDidOpen (Handler Lsp 'Method_TextDocumentDidOpen
-> ClientMessageHandler
     Lsp 'Notification 'Method_TextDocumentDidOpen
forall (f :: * -> *) (t :: MessageKind)
       (m :: Method 'ClientToServer t).
Handler f m -> ClientMessageHandler f t m
ClientMessageHandler Handler Lsp 'Method_TextDocumentDidOpen
TNotificationMessage 'Method_TextDocumentDidOpen -> Lsp ()
VFS.lspOpenFile)
    SMethodMap (ClientMessageHandler Lsp 'Notification)
-> (SMethodMap (ClientMessageHandler Lsp 'Notification)
    -> SMethodMap (ClientMessageHandler Lsp 'Notification))
-> SMethodMap (ClientMessageHandler Lsp 'Notification)
forall a b. a -> (a -> b) -> b
& SMethod 'Method_TextDocumentDidClose
-> ClientMessageHandler
     Lsp 'Notification 'Method_TextDocumentDidClose
-> SMethodMap (ClientMessageHandler Lsp 'Notification)
-> SMethodMap (ClientMessageHandler Lsp 'Notification)
forall {f :: MessageDirection} {t :: MessageKind} (a :: Method f t)
       (v :: Method f t -> *).
SMethod a -> v a -> SMethodMap v -> SMethodMap v
SMM.insert SMethod 'Method_TextDocumentDidClose
Msg.SMethod_TextDocumentDidClose (Handler Lsp 'Method_TextDocumentDidClose
-> ClientMessageHandler
     Lsp 'Notification 'Method_TextDocumentDidClose
forall (f :: * -> *) (t :: MessageKind)
       (m :: Method 'ClientToServer t).
Handler f m -> ClientMessageHandler f t m
ClientMessageHandler Handler Lsp 'Method_TextDocumentDidClose
TNotificationMessage 'Method_TextDocumentDidClose -> Lsp ()
VFS.lspCloseFile)
    SMethodMap (ClientMessageHandler Lsp 'Notification)
-> (SMethodMap (ClientMessageHandler Lsp 'Notification)
    -> SMethodMap (ClientMessageHandler Lsp 'Notification))
-> SMethodMap (ClientMessageHandler Lsp 'Notification)
forall a b. a -> (a -> b) -> b
& SMethod 'Method_TextDocumentDidChange
-> ClientMessageHandler
     Lsp 'Notification 'Method_TextDocumentDidChange
-> SMethodMap (ClientMessageHandler Lsp 'Notification)
-> SMethodMap (ClientMessageHandler Lsp 'Notification)
forall {f :: MessageDirection} {t :: MessageKind} (a :: Method f t)
       (v :: Method f t -> *).
SMethod a -> v a -> SMethodMap v -> SMethodMap v
SMM.insert SMethod 'Method_TextDocumentDidChange
Msg.SMethod_TextDocumentDidChange (Handler Lsp 'Method_TextDocumentDidChange
-> ClientMessageHandler
     Lsp 'Notification 'Method_TextDocumentDidChange
forall (f :: * -> *) (t :: MessageKind)
       (m :: Method 'ClientToServer t).
Handler f m -> ClientMessageHandler f t m
ClientMessageHandler Handler Lsp 'Method_TextDocumentDidChange
TNotificationMessage 'Method_TextDocumentDidChange -> Lsp ()
VFS.lspChangeFile)
    SMethodMap (ClientMessageHandler Lsp 'Notification)
-> (SMethodMap (ClientMessageHandler Lsp 'Notification)
    -> SMethodMap (ClientMessageHandler Lsp 'Notification))
-> SMethodMap (ClientMessageHandler Lsp 'Notification)
forall a b. a -> (a -> b) -> b
& SMethod 'Method_Initialized
-> ClientMessageHandler Lsp 'Notification 'Method_Initialized
-> SMethodMap (ClientMessageHandler Lsp 'Notification)
-> SMethodMap (ClientMessageHandler Lsp 'Notification)
forall {f :: MessageDirection} {t :: MessageKind} (a :: Method f t)
       (v :: Method f t -> *).
SMethod a -> v a -> SMethodMap v -> SMethodMap v
SMM.insert SMethod 'Method_Initialized
Msg.SMethod_Initialized (Handler Lsp 'Method_Initialized
-> ClientMessageHandler Lsp 'Notification 'Method_Initialized
forall (f :: * -> *) (t :: MessageKind)
       (m :: Method 'ClientToServer t).
Handler f m -> ClientMessageHandler f t m
ClientMessageHandler Handler Lsp 'Method_Initialized
TNotificationMessage 'Method_Initialized -> Lsp ()
Notifications.initializedHandler)
    SMethodMap (ClientMessageHandler Lsp 'Notification)
-> (SMethodMap (ClientMessageHandler Lsp 'Notification)
    -> SMethodMap (ClientMessageHandler Lsp 'Notification))
-> SMethodMap (ClientMessageHandler Lsp 'Notification)
forall a b. a -> (a -> b) -> b
& SMethod 'Method_CancelRequest
-> ClientMessageHandler Lsp 'Notification 'Method_CancelRequest
-> SMethodMap (ClientMessageHandler Lsp 'Notification)
-> SMethodMap (ClientMessageHandler Lsp 'Notification)
forall {f :: MessageDirection} {t :: MessageKind} (a :: Method f t)
       (v :: Method f t -> *).
SMethod a -> v a -> SMethodMap v -> SMethodMap v
SMM.insert SMethod 'Method_CancelRequest
forall {f :: MessageDirection}. SMethod 'Method_CancelRequest
Msg.SMethod_CancelRequest (Handler Lsp 'Method_CancelRequest
-> ClientMessageHandler Lsp 'Notification 'Method_CancelRequest
forall (f :: * -> *) (t :: MessageKind)
       (m :: Method 'ClientToServer t).
Handler f m -> ClientMessageHandler f t m
ClientMessageHandler (Handler Lsp 'Method_CancelRequest
 -> ClientMessageHandler Lsp 'Notification 'Method_CancelRequest)
-> Handler Lsp 'Method_CancelRequest
-> ClientMessageHandler Lsp 'Notification 'Method_CancelRequest
forall a b. (a -> b) -> a -> b
$ (TNotificationMessage 'Method_CancelRequest -> Lsp ())
-> TNotificationMessage 'Method_CancelRequest -> Lsp ()
forall m. Show m => (m -> Lsp ()) -> m -> Lsp ()
Notifications.withDebugging TNotificationMessage 'Method_CancelRequest -> Lsp ()
forall {f :: MessageDirection}.
TNotificationMessage 'Method_CancelRequest -> Lsp ()
cancelRequestHandler)
    SMethodMap (ClientMessageHandler Lsp 'Notification)
-> (SMethodMap (ClientMessageHandler Lsp 'Notification)
    -> SMethodMap (ClientMessageHandler Lsp 'Notification))
-> SMethodMap (ClientMessageHandler Lsp 'Notification)
forall a b. a -> (a -> b) -> b
& SMethod 'Method_WorkspaceDidChangeConfiguration
-> ClientMessageHandler
     Lsp 'Notification 'Method_WorkspaceDidChangeConfiguration
-> SMethodMap (ClientMessageHandler Lsp 'Notification)
-> SMethodMap (ClientMessageHandler Lsp 'Notification)
forall {f :: MessageDirection} {t :: MessageKind} (a :: Method f t)
       (v :: Method f t -> *).
SMethod a -> v a -> SMethodMap v -> SMethodMap v
SMM.insert SMethod 'Method_WorkspaceDidChangeConfiguration
Msg.SMethod_WorkspaceDidChangeConfiguration (Handler Lsp 'Method_WorkspaceDidChangeConfiguration
-> ClientMessageHandler
     Lsp 'Notification 'Method_WorkspaceDidChangeConfiguration
forall (f :: * -> *) (t :: MessageKind)
       (m :: Method 'ClientToServer t).
Handler f m -> ClientMessageHandler f t m
ClientMessageHandler Handler Lsp 'Method_WorkspaceDidChangeConfiguration
TNotificationMessage 'Method_WorkspaceDidChangeConfiguration
-> Lsp ()
Config.workspaceConfigurationChanged)
    SMethodMap (ClientMessageHandler Lsp 'Notification)
-> (SMethodMap (ClientMessageHandler Lsp 'Notification)
    -> SMethodMap (ClientMessageHandler Lsp 'Notification))
-> SMethodMap (ClientMessageHandler Lsp 'Notification)
forall a b. a -> (a -> b) -> b
& SMethod 'Method_SetTrace
-> ClientMessageHandler Lsp 'Notification 'Method_SetTrace
-> SMethodMap (ClientMessageHandler Lsp 'Notification)
-> SMethodMap (ClientMessageHandler Lsp 'Notification)
forall {f :: MessageDirection} {t :: MessageKind} (a :: Method f t)
       (v :: Method f t -> *).
SMethod a -> v a -> SMethodMap v -> SMethodMap v
SMM.insert SMethod 'Method_SetTrace
Msg.SMethod_SetTrace (Handler Lsp 'Method_SetTrace
-> ClientMessageHandler Lsp 'Notification 'Method_SetTrace
forall (f :: * -> *) (t :: MessageKind)
       (m :: Method 'ClientToServer t).
Handler f m -> ClientMessageHandler f t m
ClientMessageHandler Handler Lsp 'Method_SetTrace
TNotificationMessage 'Method_SetTrace -> Lsp ()
Notifications.setTraceHandler)

-- | A natural transformation into IO, required by the LSP lib.
lspInterpretHandler :: Env -> Lsp <~> IO
lspInterpretHandler :: Env -> Lsp <~> IO
lspInterpretHandler env :: Env
env@(Env {LanguageContextEnv Config
$sel:lspContext:Env :: Env -> LanguageContextEnv Config
lspContext :: LanguageContextEnv Config
lspContext}) =
  (forall a. Lsp a -> IO a)
-> (forall a. IO a -> Lsp a) -> Lsp <~> IO
forall {k} (m :: k -> *) (n :: k -> *).
(forall (a :: k). m a -> n a)
-> (forall (a :: k). n a -> m a) -> m <~> n
Iso Lsp a -> IO a
forall a. Lsp a -> IO a
toIO IO a -> Lsp a
forall a. IO a -> Lsp a
forall {m :: * -> *} {a}. MonadIO m => IO a -> m a
fromIO
  where
    toIO :: forall a. Lsp a -> IO a
    toIO :: forall a. Lsp a -> IO a
toIO (Lsp ReaderT Env (LspM Config) a
m) = (ReaderT (LanguageContextEnv Config) IO a
 -> LanguageContextEnv Config -> IO a)
-> LanguageContextEnv Config
-> ReaderT (LanguageContextEnv Config) IO a
-> IO a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT (LanguageContextEnv Config) IO a
-> LanguageContextEnv Config -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT LanguageContextEnv Config
lspContext (ReaderT (LanguageContextEnv Config) IO a -> IO a)
-> (ReaderT Env (LspM Config) a
    -> ReaderT (LanguageContextEnv Config) IO a)
-> ReaderT Env (LspM Config) a
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LspT Config IO a -> ReaderT (LanguageContextEnv Config) IO a
forall config (m :: * -> *) a.
LspT config m a -> ReaderT (LanguageContextEnv config) m a
unLspT (LspT Config IO a -> ReaderT (LanguageContextEnv Config) IO a)
-> (ReaderT Env (LspM Config) a -> LspT Config IO a)
-> ReaderT Env (LspM Config) a
-> ReaderT (LanguageContextEnv Config) IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ReaderT Env (LspM Config) a -> Env -> LspT Config IO a)
-> Env -> ReaderT Env (LspM Config) a -> LspT Config IO a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT Env (LspM Config) a -> Env -> LspT Config IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT Env
env (ReaderT Env (LspM Config) a -> IO a)
-> ReaderT Env (LspM Config) a -> IO a
forall a b. (a -> b) -> a -> b
$ ReaderT Env (LspM Config) a
m
    fromIO :: IO a -> m a
fromIO IO a
m = IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO a
m

lspOptions :: Options
lspOptions :: Options
lspOptions =
  Options
defaultOptions
    { optTextDocumentSync = Just $ textDocSyncOptions,
      optExecuteCommandCommands = Just supportedCommands
    }
  where
    textDocSyncOptions :: TextDocumentSyncOptions
textDocSyncOptions =
      TextDocumentSyncOptions
        { -- Clients should send file open/close messages so the VFS can handle them
          $sel:_openClose:TextDocumentSyncOptions :: Maybe Bool
_openClose = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True,
          -- Clients should send file change messages so the VFS can handle them
          $sel:_change:TextDocumentSyncOptions :: Maybe TextDocumentSyncKind
_change = TextDocumentSyncKind -> Maybe TextDocumentSyncKind
forall a. a -> Maybe a
Just TextDocumentSyncKind
TextDocumentSyncKind_Incremental,
          -- Clients should tell us when files are saved
          $sel:_willSave:TextDocumentSyncOptions :: Maybe Bool
_willSave = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False,
          -- If we implement a pre-save hook we can enable this.
          $sel:_willSaveWaitUntil:TextDocumentSyncOptions :: Maybe Bool
_willSaveWaitUntil = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False,
          -- If we implement a save hook we can enable this.
          $sel:_save:TextDocumentSyncOptions :: Maybe (Bool |? SaveOptions)
_save = (Bool |? SaveOptions) -> Maybe (Bool |? SaveOptions)
forall a. a -> Maybe a
Just (Bool -> Bool |? SaveOptions
forall a b. a -> a |? b
InL Bool
False)
        }