{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE RankNTypes #-}
module Development.IDE.LSP.Server
( ReactorMessage(..)
, ReactorChan
, ServerM(..)
, requestHandler
, notificationHandler
) where
import Control.Monad.IO.Unlift (MonadUnliftIO)
import Control.Monad.Reader
import Development.IDE.Core.Shake
import Development.IDE.Core.Tracing
import Ide.Types (HasTracing, traceWithSpan)
import Language.LSP.Server (Handlers, LspM)
import qualified Language.LSP.Server as LSP
import Language.LSP.Types
import Language.LSP.VFS
import UnliftIO.Chan
data ReactorMessage
= ReactorNotification (IO ())
| ReactorRequest SomeLspId (IO ()) (ResponseError -> IO ())
type ReactorChan = Chan ReactorMessage
newtype ServerM c a = ServerM { forall c a.
ServerM c a -> ReaderT (ReactorChan, IdeState) (LspM c) a
unServerM :: ReaderT (ReactorChan, IdeState) (LspM c) a }
deriving (forall a b. a -> ServerM c b -> ServerM c a
forall a b. (a -> b) -> ServerM c a -> ServerM c b
forall c a b. a -> ServerM c b -> ServerM c a
forall c a b. (a -> b) -> ServerM c a -> ServerM c b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> ServerM c b -> ServerM c a
$c<$ :: forall c a b. a -> ServerM c b -> ServerM c a
fmap :: forall a b. (a -> b) -> ServerM c a -> ServerM c b
$cfmap :: forall c a b. (a -> b) -> ServerM c a -> ServerM c b
Functor, forall c. Functor (ServerM c)
forall a. a -> ServerM c a
forall c a. a -> ServerM c a
forall a b. ServerM c a -> ServerM c b -> ServerM c a
forall a b. ServerM c a -> ServerM c b -> ServerM c b
forall a b. ServerM c (a -> b) -> ServerM c a -> ServerM c b
forall c a b. ServerM c a -> ServerM c b -> ServerM c a
forall c a b. ServerM c a -> ServerM c b -> ServerM c b
forall c a b. ServerM c (a -> b) -> ServerM c a -> ServerM c b
forall a b c.
(a -> b -> c) -> ServerM c a -> ServerM c b -> ServerM c c
forall c a b c.
(a -> b -> c) -> ServerM c a -> ServerM c b -> ServerM c c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. ServerM c a -> ServerM c b -> ServerM c a
$c<* :: forall c a b. ServerM c a -> ServerM c b -> ServerM c a
*> :: forall a b. ServerM c a -> ServerM c b -> ServerM c b
$c*> :: forall c a b. ServerM c a -> ServerM c b -> ServerM c b
liftA2 :: forall a b c.
(a -> b -> c) -> ServerM c a -> ServerM c b -> ServerM c c
$cliftA2 :: forall c a b c.
(a -> b -> c) -> ServerM c a -> ServerM c b -> ServerM c c
<*> :: forall a b. ServerM c (a -> b) -> ServerM c a -> ServerM c b
$c<*> :: forall c a b. ServerM c (a -> b) -> ServerM c a -> ServerM c b
pure :: forall a. a -> ServerM c a
$cpure :: forall c a. a -> ServerM c a
Applicative, forall c. Applicative (ServerM c)
forall a. a -> ServerM c a
forall c a. a -> ServerM c a
forall a b. ServerM c a -> ServerM c b -> ServerM c b
forall a b. ServerM c a -> (a -> ServerM c b) -> ServerM c b
forall c a b. ServerM c a -> ServerM c b -> ServerM c b
forall c a b. ServerM c a -> (a -> ServerM c b) -> ServerM c b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> ServerM c a
$creturn :: forall c a. a -> ServerM c a
>> :: forall a b. ServerM c a -> ServerM c b -> ServerM c b
$c>> :: forall c a b. ServerM c a -> ServerM c b -> ServerM c b
>>= :: forall a b. ServerM c a -> (a -> ServerM c b) -> ServerM c b
$c>>= :: forall c a b. ServerM c a -> (a -> ServerM c b) -> ServerM c b
Monad, MonadReader (ReactorChan, IdeState), forall c. Monad (ServerM c)
forall a. IO a -> ServerM c a
forall c a. IO a -> ServerM c a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: forall a. IO a -> ServerM c a
$cliftIO :: forall c a. IO a -> ServerM c a
MonadIO, forall c. MonadIO (ServerM c)
forall b. ((forall a. ServerM c a -> IO a) -> IO b) -> ServerM c b
forall c b.
((forall a. ServerM c a -> IO a) -> IO b) -> ServerM c b
forall (m :: * -> *).
MonadIO m
-> (forall b. ((forall a. m a -> IO a) -> IO b) -> m b)
-> MonadUnliftIO m
withRunInIO :: forall b. ((forall a. ServerM c a -> IO a) -> IO b) -> ServerM c b
$cwithRunInIO :: forall c b.
((forall a. ServerM c a -> IO a) -> IO b) -> ServerM c b
MonadUnliftIO, LSP.MonadLsp c)
requestHandler
:: forall (m :: Method FromClient Request) c. (HasTracing (MessageParams m)) =>
SMethod m
-> (IdeState -> MessageParams m -> LspM c (Either ResponseError (ResponseResult m)))
-> Handlers (ServerM c)
requestHandler :: forall (m :: Method 'FromClient 'Request) c.
HasTracing (MessageParams m) =>
SMethod m
-> (IdeState
-> MessageParams m
-> LspM c (Either ResponseError (ResponseResult m)))
-> Handlers (ServerM c)
requestHandler SMethod m
m IdeState
-> MessageParams m
-> LspM c (Either ResponseError (ResponseResult m))
k = forall (m :: Method 'FromClient 'Request) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
LSP.requestHandler SMethod m
m forall a b. (a -> b) -> a -> b
$ \RequestMessage{SMethod m
$sel:_method:RequestMessage :: forall (f :: From) (m :: Method f 'Request).
RequestMessage m -> SMethod m
_method :: SMethod m
_method,LspId m
$sel:_id:RequestMessage :: forall (f :: From) (m :: Method f 'Request).
RequestMessage m -> LspId m
_id :: LspId m
_id,MessageParams m
$sel:_params:RequestMessage :: forall (f :: From) (m :: Method f 'Request).
RequestMessage m -> MessageParams m
_params :: MessageParams m
_params} Either ResponseError (ResponseResult m) -> ServerM c ()
resp -> do
st :: (ReactorChan, IdeState)
st@(ReactorChan
chan,IdeState
ide) <- forall r (m :: * -> *). MonadReader r m => m r
ask
LanguageContextEnv c
env <- forall config (m :: * -> *).
MonadLsp config m =>
m (LanguageContextEnv config)
LSP.getLspEnv
let resp' :: Either ResponseError (ResponseResult m) -> LspM c ()
resp' = forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c a.
ServerM c a -> ReaderT (ReactorChan, IdeState) (LspM c) a
unServerM) (ReactorChan, IdeState)
st forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either ResponseError (ResponseResult m) -> ServerM c ()
resp
trace :: IO () -> IO ()
trace IO ()
x = forall (m :: * -> *) a.
MonadUnliftIO m =>
String -> String -> (SpanInFlight -> m a) -> m a
otTracedHandler String
"Request" (forall a. Show a => a -> String
show SMethod m
_method) forall a b. (a -> b) -> a -> b
$ \SpanInFlight
sp -> do
forall a. HasTracing a => SpanInFlight -> a -> IO ()
traceWithSpan SpanInFlight
sp MessageParams m
_params
IO ()
x
forall (m :: * -> *) a. MonadIO m => Chan a -> a -> m ()
writeChan ReactorChan
chan forall a b. (a -> b) -> a -> b
$ SomeLspId -> IO () -> (ResponseError -> IO ()) -> ReactorMessage
ReactorRequest (forall {f :: From} (m :: Method f 'Request). LspId m -> SomeLspId
SomeLspId LspId m
_id) (IO () -> IO ()
trace forall a b. (a -> b) -> a -> b
$ forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
LSP.runLspT LanguageContextEnv c
env forall a b. (a -> b) -> a -> b
$ Either ResponseError (ResponseResult m) -> LspM c ()
resp' forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IdeState
-> MessageParams m
-> LspM c (Either ResponseError (ResponseResult m))
k IdeState
ide MessageParams m
_params) (forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
LSP.runLspT LanguageContextEnv c
env forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either ResponseError (ResponseResult m) -> LspM c ()
resp' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left)
notificationHandler
:: forall (m :: Method FromClient Notification) c. (HasTracing (MessageParams m)) =>
SMethod m
-> (IdeState -> VFS -> MessageParams m -> LspM c ())
-> Handlers (ServerM c)
notificationHandler :: forall (m :: Method 'FromClient 'Notification) c.
HasTracing (MessageParams m) =>
SMethod m
-> (IdeState -> VFS -> MessageParams m -> LspM c ())
-> Handlers (ServerM c)
notificationHandler SMethod m
m IdeState -> VFS -> MessageParams m -> LspM c ()
k = forall (m :: Method 'FromClient 'Notification) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
LSP.notificationHandler SMethod m
m forall a b. (a -> b) -> a -> b
$ \NotificationMessage{MessageParams m
$sel:_params:NotificationMessage :: forall (f :: From) (m :: Method f 'Notification).
NotificationMessage m -> MessageParams m
_params :: MessageParams m
_params,SMethod m
$sel:_method:NotificationMessage :: forall (f :: From) (m :: Method f 'Notification).
NotificationMessage m -> SMethod m
_method :: SMethod m
_method}-> do
(ReactorChan
chan,IdeState
ide) <- forall r (m :: * -> *). MonadReader r m => m r
ask
LanguageContextEnv c
env <- forall config (m :: * -> *).
MonadLsp config m =>
m (LanguageContextEnv config)
LSP.getLspEnv
VFS
vfs <- forall config (m :: * -> *). MonadLsp config m => m VFS
LSP.getVirtualFiles
let trace :: IO () -> IO ()
trace IO ()
x = forall (m :: * -> *) a.
MonadUnliftIO m =>
String -> String -> (SpanInFlight -> m a) -> m a
otTracedHandler String
"Notification" (forall a. Show a => a -> String
show SMethod m
_method) forall a b. (a -> b) -> a -> b
$ \SpanInFlight
sp -> do
forall a. HasTracing a => SpanInFlight -> a -> IO ()
traceWithSpan SpanInFlight
sp MessageParams m
_params
IO ()
x
forall (m :: * -> *) a. MonadIO m => Chan a -> a -> m ()
writeChan ReactorChan
chan forall a b. (a -> b) -> a -> b
$ IO () -> ReactorMessage
ReactorNotification (IO () -> IO ()
trace forall a b. (a -> b) -> a -> b
$ forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
LSP.runLspT LanguageContextEnv c
env forall a b. (a -> b) -> a -> b
$ IdeState -> VFS -> MessageParams m -> LspM c ()
k IdeState
ide VFS
vfs MessageParams m
_params)