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

{-# 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
  -- 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 () -> 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)