{-# LANGUAGE UndecidableInstances #-}
-- Copyright (c) 2019 The DAML Authors. All rights reserved.
-- SPDX-License-Identifier: Apache-2.0

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
import           Language.LSP.Protocol.Message
import           Language.LSP.Server           (Handlers, LspM)
import qualified Language.LSP.Server           as LSP
import           Language.LSP.VFS
import           UnliftIO.Chan

data ReactorMessage
  = ReactorNotification (IO ())
  | forall m . ReactorRequest (LspId m) (IO ()) (TResponseError m -> 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 -> b) -> ServerM c a -> ServerM c b)
-> (forall a b. a -> ServerM c b -> ServerM c a)
-> Functor (ServerM c)
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
$cfmap :: forall c a b. (a -> b) -> ServerM c a -> ServerM c b
fmap :: forall a b. (a -> b) -> ServerM c a -> ServerM c b
$c<$ :: forall c a b. a -> ServerM c b -> ServerM c a
<$ :: forall a b. a -> ServerM c b -> ServerM c a
Functor, Functor (ServerM c)
Functor (ServerM c) =>
(forall a. a -> ServerM c a)
-> (forall 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 a b. ServerM c a -> ServerM c b -> ServerM c b)
-> (forall a b. ServerM c a -> ServerM c b -> ServerM c a)
-> Applicative (ServerM c)
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
$cpure :: forall c a. a -> ServerM c a
pure :: forall a. a -> ServerM c a
$c<*> :: forall c a b. ServerM c (a -> b) -> ServerM c a -> ServerM c b
<*> :: forall a b. ServerM c (a -> b) -> ServerM c a -> ServerM c b
$cliftA2 :: forall c a b c.
(a -> b -> c) -> ServerM c a -> ServerM c b -> ServerM c c
liftA2 :: forall a b c.
(a -> b -> c) -> ServerM c a -> ServerM c b -> ServerM c c
$c*> :: forall c a b. ServerM c a -> ServerM c b -> ServerM c b
*> :: 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 a
<* :: forall a b. ServerM c a -> ServerM c b -> ServerM c a
Applicative, Applicative (ServerM c)
Applicative (ServerM c) =>
(forall a b. ServerM c a -> (a -> ServerM c b) -> ServerM c b)
-> (forall a b. ServerM c a -> ServerM c b -> ServerM c b)
-> (forall a. a -> ServerM c a)
-> Monad (ServerM c)
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
$c>>= :: forall c a b. ServerM c a -> (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 -> ServerM c b -> ServerM c b
>> :: forall a b. ServerM c a -> ServerM c b -> ServerM c b
$creturn :: forall c a. a -> ServerM c a
return :: forall a. a -> ServerM c a
Monad, MonadReader (ReactorChan, IdeState), Monad (ServerM c)
Monad (ServerM c) =>
(forall a. IO a -> ServerM c a) -> MonadIO (ServerM c)
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
$cliftIO :: forall c a. IO a -> ServerM c a
liftIO :: forall a. IO a -> ServerM c a
MonadIO, MonadIO (ServerM c)
MonadIO (ServerM c) =>
(forall b.
 ((forall a. ServerM c a -> IO a) -> IO b) -> ServerM c b)
-> MonadUnliftIO (ServerM c)
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
$cwithRunInIO :: forall c b.
((forall a. ServerM c a -> IO a) -> IO b) -> ServerM c b
withRunInIO :: forall b. ((forall a. ServerM c a -> IO a) -> IO b) -> ServerM c b
MonadUnliftIO, LSP.MonadLsp c)

requestHandler
  :: forall m c. PluginMethod Request m =>
     SMethod m
  -> (IdeState -> MessageParams m -> LspM c (Either (TResponseError m) (MessageResult m)))
  -> Handlers (ServerM c)
requestHandler :: forall (m :: Method 'ClientToServer 'Request) c.
PluginMethod 'Request m =>
SMethod m
-> (IdeState
    -> MessageParams m
    -> LspM c (Either (TResponseError m) (MessageResult m)))
-> Handlers (ServerM c)
requestHandler SMethod m
m IdeState
-> MessageParams m
-> LspM c (Either (TResponseError m) (MessageResult m))
k = SMethod m -> Handler (ServerM c) m -> Handlers (ServerM c)
forall (m :: Method 'ClientToServer 'Request) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
LSP.requestHandler SMethod m
m (Handler (ServerM c) m -> Handlers (ServerM c))
-> Handler (ServerM c) m -> Handlers (ServerM c)
forall a b. (a -> b) -> a -> b
$ \TRequestMessage{SMethod m
_method :: SMethod m
$sel:_method:TRequestMessage :: forall (f :: MessageDirection) (m :: Method f 'Request).
TRequestMessage m -> SMethod m
_method,LspId m
_id :: LspId m
$sel:_id:TRequestMessage :: forall (f :: MessageDirection) (m :: Method f 'Request).
TRequestMessage m -> LspId m
_id,MessageParams m
_params :: MessageParams m
$sel:_params:TRequestMessage :: forall (f :: MessageDirection) (m :: Method f 'Request).
TRequestMessage m -> MessageParams m
_params} Either (TResponseError m) (MessageResult m) -> ServerM c ()
resp -> do
  st :: (ReactorChan, IdeState)
st@(ReactorChan
chan,IdeState
ide) <- ServerM c (ReactorChan, IdeState)
forall r (m :: * -> *). MonadReader r m => m r
ask
  LanguageContextEnv c
env <- ServerM c (LanguageContextEnv c)
forall config (m :: * -> *).
MonadLsp config m =>
m (LanguageContextEnv config)
LSP.getLspEnv
  let resp' :: Either (TResponseError m) (MessageResult m) -> LspM c ()
      resp' :: Either (TResponseError m) (MessageResult m) -> LspM c ()
resp' = (ServerM c () -> (ReactorChan, IdeState) -> LspM c ())
-> (ReactorChan, IdeState) -> ServerM c () -> LspM c ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (ReaderT (ReactorChan, IdeState) (LspT c IO) ()
-> (ReactorChan, IdeState) -> LspM c ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (ReaderT (ReactorChan, IdeState) (LspT c IO) ()
 -> (ReactorChan, IdeState) -> LspM c ())
-> (ServerM c () -> ReaderT (ReactorChan, IdeState) (LspT c IO) ())
-> ServerM c ()
-> (ReactorChan, IdeState)
-> LspM c ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerM c () -> ReaderT (ReactorChan, IdeState) (LspT c IO) ()
forall c a.
ServerM c a -> ReaderT (ReactorChan, IdeState) (LspM c) a
unServerM) (ReactorChan, IdeState)
st (ServerM c () -> LspM c ())
-> (Either (TResponseError m) (MessageResult m) -> ServerM c ())
-> Either (TResponseError m) (MessageResult m)
-> LspM c ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either (TResponseError m) (MessageResult m) -> ServerM c ()
resp
      trace :: IO a -> IO a
trace IO a
x = String -> String -> (SpanInFlight -> IO a) -> IO a
forall (m :: * -> *) a.
MonadUnliftIO m =>
String -> String -> (SpanInFlight -> m a) -> m a
otTracedHandler String
"Request" (SMethod m -> String
forall a. Show a => a -> String
show SMethod m
_method) ((SpanInFlight -> IO a) -> IO a) -> (SpanInFlight -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \SpanInFlight
sp -> do
        SpanInFlight -> MessageParams m -> IO ()
forall a. HasTracing a => SpanInFlight -> a -> IO ()
traceWithSpan SpanInFlight
sp MessageParams m
_params
        IO a
x
  ReactorChan -> ReactorMessage -> ServerM c ()
forall (m :: * -> *) a. MonadIO m => Chan a -> a -> m ()
writeChan ReactorChan
chan (ReactorMessage -> ServerM c ()) -> ReactorMessage -> ServerM c ()
forall a b. (a -> b) -> a -> b
$ LspId m -> IO () -> (TResponseError m -> IO ()) -> ReactorMessage
forall {f :: MessageDirection} (m :: Method f 'Request).
LspId m -> IO () -> (TResponseError m -> IO ()) -> ReactorMessage
ReactorRequest (LspId m
_id) (IO () -> IO ()
forall {a}. IO a -> IO a
trace (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ LanguageContextEnv c -> LspM c () -> IO ()
forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
LSP.runLspT LanguageContextEnv c
env (LspM c () -> IO ()) -> LspM c () -> IO ()
forall a b. (a -> b) -> a -> b
$ Either (TResponseError m) (MessageResult m) -> LspM c ()
resp' (Either (TResponseError m) (MessageResult m) -> LspM c ())
-> LspM c (Either (TResponseError m) (MessageResult m))
-> LspM c ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IdeState
-> MessageParams m
-> LspM c (Either (TResponseError m) (MessageResult m))
k IdeState
ide MessageParams m
_params) (LanguageContextEnv c -> LspM c () -> IO ()
forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
LSP.runLspT LanguageContextEnv c
env (LspM c () -> IO ())
-> (TResponseError m -> LspM c ()) -> TResponseError m -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either (TResponseError m) (MessageResult m) -> LspM c ()
resp' (Either (TResponseError m) (MessageResult m) -> LspM c ())
-> (TResponseError m
    -> Either (TResponseError m) (MessageResult m))
-> TResponseError m
-> LspM c ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TResponseError m -> Either (TResponseError m) (MessageResult m)
forall a b. a -> Either a b
Left)

notificationHandler
  :: forall m c. PluginMethod Notification m =>
     SMethod m
  -> (IdeState -> VFS -> MessageParams m -> LspM c ())
  -> Handlers (ServerM c)
notificationHandler :: forall (m :: Method 'ClientToServer 'Notification) c.
PluginMethod 'Notification m =>
SMethod m
-> (IdeState -> VFS -> MessageParams m -> LspM c ())
-> Handlers (ServerM c)
notificationHandler SMethod m
m IdeState -> VFS -> MessageParams m -> LspM c ()
k = SMethod m -> Handler (ServerM c) m -> Handlers (ServerM c)
forall (m :: Method 'ClientToServer 'Notification) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
LSP.notificationHandler SMethod m
m (Handler (ServerM c) m -> Handlers (ServerM c))
-> Handler (ServerM c) m -> Handlers (ServerM c)
forall a b. (a -> b) -> a -> b
$ \TNotificationMessage{MessageParams m
_params :: MessageParams m
$sel:_params:TNotificationMessage :: forall (f :: MessageDirection) (m :: Method f 'Notification).
TNotificationMessage m -> MessageParams m
_params,SMethod m
_method :: SMethod m
$sel:_method:TNotificationMessage :: forall (f :: MessageDirection) (m :: Method f 'Notification).
TNotificationMessage m -> SMethod m
_method}-> do
  (ReactorChan
chan,IdeState
ide) <- ServerM c (ReactorChan, IdeState)
forall r (m :: * -> *). MonadReader r m => m r
ask
  LanguageContextEnv c
env <- ServerM c (LanguageContextEnv c)
forall config (m :: * -> *).
MonadLsp config m =>
m (LanguageContextEnv config)
LSP.getLspEnv
  -- Take a snapshot of the VFS state on every notification
  -- We only need to do this here because the VFS state is only updated
  -- on notifications
  VFS
vfs <- ServerM c VFS
forall config (m :: * -> *). MonadLsp config m => m VFS
LSP.getVirtualFiles
  let trace :: IO a -> IO a
trace IO a
x = String -> String -> (SpanInFlight -> IO a) -> IO a
forall (m :: * -> *) a.
MonadUnliftIO m =>
String -> String -> (SpanInFlight -> m a) -> m a
otTracedHandler String
"Notification" (SMethod m -> String
forall a. Show a => a -> String
show SMethod m
_method) ((SpanInFlight -> IO a) -> IO a) -> (SpanInFlight -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \SpanInFlight
sp -> do
        SpanInFlight -> MessageParams m -> IO ()
forall a. HasTracing a => SpanInFlight -> a -> IO ()
traceWithSpan SpanInFlight
sp MessageParams m
_params
        IO a
x
  ReactorChan -> ReactorMessage -> ServerM c ()
forall (m :: * -> *) a. MonadIO m => Chan a -> a -> m ()
writeChan ReactorChan
chan (ReactorMessage -> ServerM c ()) -> ReactorMessage -> ServerM c ()
forall a b. (a -> b) -> a -> b
$ IO () -> ReactorMessage
ReactorNotification (IO () -> IO ()
forall {a}. IO a -> IO a
trace (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ LanguageContextEnv c -> LspM c () -> IO ()
forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
LSP.runLspT LanguageContextEnv c
env (LspM c () -> IO ()) -> LspM c () -> IO ()
forall a b. (a -> b) -> a -> b
$ IdeState -> VFS -> MessageParams m -> LspM c ()
k IdeState
ide VFS
vfs MessageParams m
_params)