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

{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE GADTs #-}
module Development.IDE.LSP.Server
  ( ReactorMessage(..)
  , ReactorChan
  , ServerM
  , requestHandler
  , notificationHandler
  ) where

import Language.LSP.Server (LspM, Handlers)
import Language.LSP.Types
import qualified Language.LSP.Server as LSP
import Development.IDE.Core.Shake
import UnliftIO.Chan
import Control.Monad.Reader
import Ide.Types (HasTracing, traceWithSpan)
import Development.IDE.Core.Tracing

data ReactorMessage
  = ReactorNotification (IO ())
  | ReactorRequest SomeLspId (IO ()) (ResponseError -> IO ())

type ReactorChan = Chan ReactorMessage
type ServerM c = ReaderT (ReactorChan, IdeState) (LspM 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
-> (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 = SMethod m -> Handler (ServerM c) m -> Handlers (ServerM c)
forall (m :: Method 'FromClient '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
$ \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)
-> ReaderT (Chan ReactorMessage, IdeState) (LspT c IO) ()
resp -> do
  st :: (Chan ReactorMessage, IdeState)
st@(Chan ReactorMessage
chan,IdeState
ide) <- ReaderT
  (Chan ReactorMessage, IdeState)
  (LspT c IO)
  (Chan ReactorMessage, IdeState)
forall r (m :: * -> *). MonadReader r m => m r
ask
  LanguageContextEnv c
env <- ReaderT
  (Chan ReactorMessage, IdeState) (LspT c IO) (LanguageContextEnv c)
forall config (m :: * -> *).
MonadLsp config m =>
m (LanguageContextEnv config)
LSP.getLspEnv
  let resp' :: Either ResponseError (ResponseResult m) -> LspT c IO ()
resp' = (ReaderT (Chan ReactorMessage, IdeState) (LspT c IO) ()
 -> (Chan ReactorMessage, IdeState) -> LspT c IO ())
-> (Chan ReactorMessage, IdeState)
-> ReaderT (Chan ReactorMessage, IdeState) (LspT c IO) ()
-> LspT c IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT (Chan ReactorMessage, IdeState) (LspT c IO) ()
-> (Chan ReactorMessage, IdeState) -> LspT c IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Chan ReactorMessage, IdeState)
st (ReaderT (Chan ReactorMessage, IdeState) (LspT c IO) ()
 -> LspT c IO ())
-> (Either ResponseError (ResponseResult m)
    -> ReaderT (Chan ReactorMessage, IdeState) (LspT c IO) ())
-> Either ResponseError (ResponseResult m)
-> LspT c IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either ResponseError (ResponseResult m)
-> ReaderT (Chan ReactorMessage, IdeState) (LspT c IO) ()
resp
      trace :: IO () -> IO ()
trace IO ()
x = String -> String -> (SpanInFlight -> IO ()) -> IO ()
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 ()) -> IO ())
-> (SpanInFlight -> IO ()) -> IO ()
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 ()
x
  Chan ReactorMessage
-> ReactorMessage
-> ReaderT (Chan ReactorMessage, IdeState) (LspT c IO) ()
forall (m :: * -> *) a. MonadIO m => Chan a -> a -> m ()
writeChan Chan ReactorMessage
chan (ReactorMessage
 -> ReaderT (Chan ReactorMessage, IdeState) (LspT c IO) ())
-> ReactorMessage
-> ReaderT (Chan ReactorMessage, IdeState) (LspT c IO) ()
forall a b. (a -> b) -> a -> b
$ SomeLspId -> IO () -> (ResponseError -> IO ()) -> ReactorMessage
ReactorRequest (LspId m -> SomeLspId
forall (f :: From) (m :: Method f 'Request). LspId m -> SomeLspId
SomeLspId LspId m
_id) (IO () -> IO ()
trace (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ LanguageContextEnv c -> LspT c IO () -> IO ()
forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
LSP.runLspT LanguageContextEnv c
env (LspT c IO () -> IO ()) -> LspT c IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Either ResponseError (ResponseResult m) -> LspT c IO ()
resp' (Either ResponseError (ResponseResult m) -> LspT c IO ())
-> LspM c (Either ResponseError (ResponseResult m)) -> LspT c IO ()
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) (LanguageContextEnv c -> LspT c IO () -> IO ()
forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
LSP.runLspT LanguageContextEnv c
env (LspT c IO () -> IO ())
-> (ResponseError -> LspT c IO ()) -> ResponseError -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either ResponseError (ResponseResult m) -> LspT c IO ()
resp' (Either ResponseError (ResponseResult m) -> LspT c IO ())
-> (ResponseError -> Either ResponseError (ResponseResult m))
-> ResponseError
-> LspT c IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResponseError -> Either ResponseError (ResponseResult m)
forall a b. a -> Either a b
Left)

notificationHandler
  :: forall (m :: Method FromClient Notification) c. (HasTracing (MessageParams m)) =>
     SMethod m
  -> (IdeState -> MessageParams m -> LspM c ())
  -> Handlers (ServerM c)
notificationHandler :: SMethod m
-> (IdeState -> MessageParams m -> LspM c ())
-> Handlers (ServerM c)
notificationHandler SMethod m
m IdeState -> MessageParams m -> LspM c ()
k = SMethod m -> Handler (ServerM c) m -> Handlers (ServerM c)
forall (m :: Method 'FromClient '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
$ \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
  (Chan ReactorMessage
chan,IdeState
ide) <- ReaderT
  (Chan ReactorMessage, IdeState)
  (LspM c)
  (Chan ReactorMessage, IdeState)
forall r (m :: * -> *). MonadReader r m => m r
ask
  LanguageContextEnv c
env <- ReaderT
  (Chan ReactorMessage, IdeState) (LspM c) (LanguageContextEnv c)
forall config (m :: * -> *).
MonadLsp config m =>
m (LanguageContextEnv config)
LSP.getLspEnv
  let trace :: IO () -> IO ()
trace IO ()
x = String -> String -> (SpanInFlight -> IO ()) -> IO ()
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 ()) -> IO ())
-> (SpanInFlight -> IO ()) -> IO ()
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 ()
x
  Chan ReactorMessage
-> ReactorMessage
-> ReaderT (Chan ReactorMessage, IdeState) (LspM c) ()
forall (m :: * -> *) a. MonadIO m => Chan a -> a -> m ()
writeChan Chan ReactorMessage
chan (ReactorMessage
 -> ReaderT (Chan ReactorMessage, IdeState) (LspM c) ())
-> ReactorMessage
-> ReaderT (Chan ReactorMessage, IdeState) (LspM c) ()
forall a b. (a -> b) -> a -> b
$ IO () -> ReactorMessage
ReactorNotification (IO () -> IO ()
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 -> MessageParams m -> LspM c ()
k IdeState
ide MessageParams m
_params)