{-# LANGUAGE FlexibleInstances    #-}
{-# 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 ())
  | 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 c. PluginMethod Request m =>
     SMethod m
  -> (IdeState -> MessageParams m -> LspM c (Either ResponseError (MessageResult m)))
  -> Handlers (ServerM c)
requestHandler :: forall (m :: Method 'ClientToServer 'Request) c.
PluginMethod 'Request m =>
SMethod m
-> (IdeState
    -> MessageParams m
    -> LspM c (Either ResponseError (MessageResult m)))
-> Handlers (ServerM c)
requestHandler SMethod m
m IdeState
-> MessageParams m
-> LspM c (Either ResponseError (MessageResult m))
k = forall (m :: Method 'ClientToServer 'Request) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
LSP.requestHandler SMethod m
m forall a b. (a -> b) -> a -> b
$ \TRequestMessage{SMethod m
$sel:_method:TRequestMessage :: forall (f :: MessageDirection) (m :: Method f 'Request).
TRequestMessage m -> SMethod m
_method :: SMethod m
_method,LspId m
$sel:_id:TRequestMessage :: forall (f :: MessageDirection) (m :: Method f 'Request).
TRequestMessage m -> LspId m
_id :: LspId m
_id,MessageParams m
$sel:_params:TRequestMessage :: forall (f :: MessageDirection) (m :: Method f 'Request).
TRequestMessage m -> MessageParams m
_params :: MessageParams m
_params} Either ResponseError (MessageResult 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 (MessageResult m) -> LspM c ()
      resp' :: Either ResponseError (MessageResult 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 (MessageResult m) -> ServerM c ()
resp
      trace :: IO a -> IO a
trace IO a
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 a
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 :: MessageDirection} (m :: Method f 'Request).
LspId m -> SomeLspId
SomeLspId LspId m
_id) (forall {a}. IO a -> IO a
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 (MessageResult m) -> LspM c ()
resp' forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IdeState
-> MessageParams m
-> LspM c (Either ResponseError (MessageResult 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 (MessageResult 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 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 = forall (m :: Method 'ClientToServer 'Notification) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
LSP.notificationHandler SMethod m
m forall a b. (a -> b) -> a -> b
$ \TNotificationMessage{MessageParams m
$sel:_params:TNotificationMessage :: forall (f :: MessageDirection) (m :: Method f 'Notification).
TNotificationMessage m -> MessageParams m
_params :: MessageParams m
_params,SMethod m
$sel:_method:TNotificationMessage :: forall (f :: MessageDirection) (m :: Method f 'Notification).
TNotificationMessage 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
  -- 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 <- forall config (m :: * -> *). MonadLsp config m => m VFS
LSP.getVirtualFiles
  let trace :: IO a -> IO a
trace IO a
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 a
x
  forall (m :: * -> *) a. MonadIO m => Chan a -> a -> m ()
writeChan ReactorChan
chan forall a b. (a -> b) -> a -> b
$ IO () -> ReactorMessage
ReactorNotification (forall {a}. IO a -> IO a
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)