-- Copyright (c) 2019 The DAML Authors. All rights reserved.

-- SPDX-License-Identifier: Apache-2.0


{-# LANGUAGE ExistentialQuantification  #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}

-- WARNING: A copy of DA.Daml.LanguageServer, try to keep them in sync

-- This version removes the daml: handling

module Development.IDE.LSP.LanguageServer
    ( runLanguageServer
    ) where

import           Language.LSP.Types
import           Development.IDE.LSP.Server
import qualified Development.IDE.GHC.Util as Ghcide
import qualified Language.LSP.Server as LSP
import Control.Concurrent.Extra (newBarrier, signalBarrier, waitBarrier)
import Control.Concurrent.STM
import Data.Maybe
import Data.Aeson (Value)
import qualified Data.Set as Set
import qualified Data.Text as T
import GHC.IO.Handle (hDuplicate)
import System.IO
import Control.Monad.Extra
import UnliftIO.Exception
import UnliftIO.Async
import UnliftIO.Concurrent
import UnliftIO.Directory
import Control.Monad.IO.Class
import Control.Monad.Reader
import Ide.Types (traceWithSpan)
import Development.IDE.Session (runWithDb)

import Development.IDE.Core.IdeConfiguration
import Development.IDE.Core.Shake
import Development.IDE.LSP.HoverDefinition
import Development.IDE.LSP.Notifications
import Development.IDE.Types.Logger
import Development.IDE.Core.FileStore
import Development.IDE.Core.Tracing

import System.IO.Unsafe (unsafeInterleaveIO)

runLanguageServer
    :: forall config. (Show config)
    => LSP.Options
    -> (FilePath -> IO FilePath) -- ^ Map root paths to the location of the hiedb for the project

    -> (IdeState -> Value -> IO (Either T.Text config))
    -> LSP.Handlers (ServerM config)
    -> (LSP.LanguageContextEnv config -> VFSHandle -> Maybe FilePath -> HieDb -> IndexQueue -> IO IdeState)
    -> IO ()
runLanguageServer :: Options
-> (FilePath -> IO FilePath)
-> (IdeState -> Value -> IO (Either Text config))
-> Handlers (ServerM config)
-> (LanguageContextEnv config
    -> VFSHandle
    -> Maybe FilePath
    -> HieDb
    -> IndexQueue
    -> IO IdeState)
-> IO ()
runLanguageServer Options
options FilePath -> IO FilePath
getHieDbLoc IdeState -> Value -> IO (Either Text config)
onConfigurationChange Handlers (ServerM config)
userHandlers LanguageContextEnv config
-> VFSHandle
-> Maybe FilePath
-> HieDb
-> IndexQueue
-> IO IdeState
getIdeState = do
    -- Move stdout to another file descriptor and duplicate stderr

    -- to stdout. This guards against stray prints from corrupting the JSON-RPC

    -- message stream.

    Handle
newStdout <- Handle -> IO Handle
hDuplicate Handle
stdout
    Handle
stderr Handle -> Handle -> IO ()
`Ghcide.hDuplicateTo'` Handle
stdout
    Handle -> BufferMode -> IO ()
hSetBuffering Handle
stderr BufferMode
NoBuffering
    Handle -> BufferMode -> IO ()
hSetBuffering Handle
stdout BufferMode
NoBuffering

    -- Print out a single space to assert that the above redirection works.

    -- This is interleaved with the logger, hence we just print a space here in

    -- order not to mess up the output too much. Verified that this breaks

    -- the language server tests without the redirection.

    FilePath -> IO ()
putStr FilePath
" " IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
stdout

    -- These barriers are signaled when the threads reading from these chans exit.

    -- This should not happen but if it does, we will make sure that the whole server

    -- dies and can be restarted instead of losing threads silently.

    Barrier ()
clientMsgBarrier <- IO (Barrier ())
forall a. IO (Barrier a)
newBarrier
    -- Forcefully exit

    let exit :: IO ()
exit = Barrier () -> () -> IO ()
forall a. Partial => Barrier a -> a -> IO ()
signalBarrier Barrier ()
clientMsgBarrier ()

    -- The set of requests ids that we have received but not finished processing

    TVar (Set SomeLspId)
pendingRequests <- Set SomeLspId -> IO (TVar (Set SomeLspId))
forall a. a -> IO (TVar a)
newTVarIO Set SomeLspId
forall a. Set a
Set.empty
    -- The set of requests that have been cancelled and are also in pendingRequests

    TVar (Set SomeLspId)
cancelledRequests <- Set SomeLspId -> IO (TVar (Set SomeLspId))
forall a. a -> IO (TVar a)
newTVarIO Set SomeLspId
forall a. Set a
Set.empty

    let cancelRequest :: SomeLspId -> IO ()
cancelRequest SomeLspId
reqId = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            Set SomeLspId
queued <- TVar (Set SomeLspId) -> STM (Set SomeLspId)
forall a. TVar a -> STM a
readTVar TVar (Set SomeLspId)
pendingRequests
            -- We want to avoid that the list of cancelled requests

            -- keeps growing if we receive cancellations for requests

            -- that do not exist or have already been processed.

            Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SomeLspId
reqId SomeLspId -> Set SomeLspId -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Set SomeLspId
queued) (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$
                TVar (Set SomeLspId) -> (Set SomeLspId -> Set SomeLspId) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Set SomeLspId)
cancelledRequests (SomeLspId -> Set SomeLspId -> Set SomeLspId
forall a. Ord a => a -> Set a -> Set a
Set.insert SomeLspId
reqId)
    let clearReqId :: SomeLspId -> IO ()
clearReqId SomeLspId
reqId = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            TVar (Set SomeLspId) -> (Set SomeLspId -> Set SomeLspId) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Set SomeLspId)
pendingRequests (SomeLspId -> Set SomeLspId -> Set SomeLspId
forall a. Ord a => a -> Set a -> Set a
Set.delete SomeLspId
reqId)
            TVar (Set SomeLspId) -> (Set SomeLspId -> Set SomeLspId) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Set SomeLspId)
cancelledRequests (SomeLspId -> Set SomeLspId -> Set SomeLspId
forall a. Ord a => a -> Set a -> Set a
Set.delete SomeLspId
reqId)
        -- We implement request cancellation by racing waitForCancel against

        -- the actual request handler.

    let waitForCancel :: SomeLspId -> IO ()
waitForCancel SomeLspId
reqId = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            Set SomeLspId
cancelled <- TVar (Set SomeLspId) -> STM (Set SomeLspId)
forall a. TVar a -> STM a
readTVar TVar (Set SomeLspId)
cancelledRequests
            Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (SomeLspId
reqId SomeLspId -> Set SomeLspId -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set SomeLspId
cancelled) STM ()
forall a. STM a
retry

    let ideHandlers :: Handlers (ServerM config)
ideHandlers = [Handlers (ServerM config)] -> Handlers (ServerM config)
forall a. Monoid a => [a] -> a
mconcat
          [ Handlers (ServerM config)
forall c. Handlers (ServerM c)
setIdeHandlers
          , Handlers (ServerM config)
userHandlers
          , Handlers (ServerM config)
forall c. Handlers (ServerM c)
setHandlersNotifications -- absolutely critical, join them with user notifications

          ]

    -- Send everything over a channel, since you need to wait until after initialise before

    -- LspFuncs is available

    Chan ReactorMessage
clientMsgChan :: Chan ReactorMessage <- IO (Chan ReactorMessage)
forall (m :: * -> *) a. MonadIO m => m (Chan a)
newChan

    let asyncHandlers :: Handlers (ServerM config)
asyncHandlers = [Handlers (ServerM config)] -> Handlers (ServerM config)
forall a. Monoid a => [a] -> a
mconcat
          [ Handlers (ServerM config)
ideHandlers
          , (SomeLspId -> IO ()) -> Handlers (ServerM config)
forall c. (SomeLspId -> IO ()) -> Handlers (ServerM c)
cancelHandler SomeLspId -> IO ()
cancelRequest
          , IO () -> Handlers (ServerM config)
forall c. IO () -> Handlers (ServerM c)
exitHandler IO ()
exit
          ]
          -- Cancel requests are special since they need to be handled

          -- out of order to be useful. Existing handlers are run afterwards.



    let serverDefinition :: ServerDefinition config
serverDefinition = ServerDefinition :: forall config (m :: * -> *) a.
(Value -> m (Either Text config))
-> (LanguageContextEnv config
    -> Message 'Initialize -> IO (Either ResponseError a))
-> Handlers m
-> (a -> m <~> IO)
-> Options
-> ServerDefinition config
LSP.ServerDefinition
            { onConfigurationChange :: Value -> ServerM config (Either Text config)
LSP.onConfigurationChange = \Value
v -> do
                (Chan ReactorMessage
_chan, IdeState
ide) <- ServerM config (Chan ReactorMessage, IdeState)
forall r (m :: * -> *). MonadReader r m => m r
ask
                IO (Either Text config) -> ServerM config (Either Text config)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either Text config) -> ServerM config (Either Text config))
-> IO (Either Text config) -> ServerM config (Either Text config)
forall a b. (a -> b) -> a -> b
$ IdeState -> Value -> IO (Either Text config)
onConfigurationChange IdeState
ide Value
v
            , doInitialize :: LanguageContextEnv config
-> Message 'Initialize
-> IO (Either ResponseError (LanguageContextEnv config, IdeState))
LSP.doInitialize = IO ()
-> (SomeLspId -> IO ())
-> (SomeLspId -> IO ())
-> Chan ReactorMessage
-> LanguageContextEnv config
-> RequestMessage 'Initialize
-> IO (Either ResponseError (LanguageContextEnv config, IdeState))
forall err.
IO ()
-> (SomeLspId -> IO ())
-> (SomeLspId -> IO ())
-> Chan ReactorMessage
-> LanguageContextEnv config
-> RequestMessage 'Initialize
-> IO (Either err (LanguageContextEnv config, IdeState))
handleInit IO ()
exit SomeLspId -> IO ()
clearReqId SomeLspId -> IO ()
waitForCancel Chan ReactorMessage
clientMsgChan
            , staticHandlers :: Handlers (ServerM config)
LSP.staticHandlers = Handlers (ServerM config)
asyncHandlers
            , interpretHandler :: (LanguageContextEnv config, IdeState) -> ServerM config <~> IO
LSP.interpretHandler = \(LanguageContextEnv config
env, IdeState
st) -> (forall a. ServerM config a -> IO a)
-> (forall a. IO a -> ServerM config a) -> ServerM config <~> IO
forall k (m :: k -> *) (n :: k -> *).
(forall (a :: k). m a -> n a)
-> (forall (a :: k). n a -> m a) -> m <~> n
LSP.Iso (LanguageContextEnv config -> LspT config IO a -> IO a
forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
LSP.runLspT LanguageContextEnv config
env (LspT config IO a -> IO a)
-> (ReaderT (Chan ReactorMessage, IdeState) (LspT config IO) a
    -> LspT config IO a)
-> ReaderT (Chan ReactorMessage, IdeState) (LspT config IO) a
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ReaderT (Chan ReactorMessage, IdeState) (LspT config IO) a
 -> (Chan ReactorMessage, IdeState) -> LspT config IO a)
-> (Chan ReactorMessage, IdeState)
-> ReaderT (Chan ReactorMessage, IdeState) (LspT config IO) a
-> LspT config IO a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT (Chan ReactorMessage, IdeState) (LspT config IO) a
-> (Chan ReactorMessage, IdeState) -> LspT config IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Chan ReactorMessage
clientMsgChan,IdeState
st)) forall a. IO a -> ServerM config a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
            , options :: Options
LSP.options = Options -> Options
modifyOptions Options
options
            }

    IO (Async (), ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Async (), ()) -> IO ()) -> IO (Async (), ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ [Async ()] -> IO (Async (), ())
forall (m :: * -> *) a. MonadIO m => [Async a] -> m (Async a, a)
waitAnyCancel ([Async ()] -> IO (Async (), ()))
-> IO [Async ()] -> IO (Async (), ())
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (IO () -> IO (Async ())) -> [IO ()] -> IO [Async ()]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse IO () -> IO (Async ())
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async
        [ IO Int -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Int -> IO ()) -> IO Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> Handle -> ServerDefinition config -> IO Int
forall config.
Handle -> Handle -> ServerDefinition config -> IO Int
LSP.runServerWithHandles
            Handle
stdin
            Handle
newStdout
            ServerDefinition config
serverDefinition
        , IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Barrier () -> IO ()
forall a. Barrier a -> IO a
waitBarrier Barrier ()
clientMsgBarrier
        ]

    where
        handleInit
          :: IO () -> (SomeLspId -> IO ()) -> (SomeLspId -> IO ()) -> Chan ReactorMessage
          -> LSP.LanguageContextEnv config -> RequestMessage Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState))
        handleInit :: IO ()
-> (SomeLspId -> IO ())
-> (SomeLspId -> IO ())
-> Chan ReactorMessage
-> LanguageContextEnv config
-> RequestMessage 'Initialize
-> IO (Either err (LanguageContextEnv config, IdeState))
handleInit IO ()
exitClientMsg SomeLspId -> IO ()
clearReqId SomeLspId -> IO ()
waitForCancel Chan ReactorMessage
clientMsgChan LanguageContextEnv config
env (RequestMessage Text
_ LspId 'Initialize
_ SMethod 'Initialize
m MessageParams 'Initialize
params) = FilePath
-> FilePath
-> (SpanInFlight
    -> IO (Either err (LanguageContextEnv config, IdeState)))
-> IO (Either err (LanguageContextEnv config, IdeState))
forall (m :: * -> *) a.
MonadUnliftIO m =>
FilePath -> FilePath -> (SpanInFlight -> m a) -> m a
otTracedHandler FilePath
"Initialize" (SMethod 'Initialize -> FilePath
forall a. Show a => a -> FilePath
show SMethod 'Initialize
m) ((SpanInFlight
  -> IO (Either err (LanguageContextEnv config, IdeState)))
 -> IO (Either err (LanguageContextEnv config, IdeState)))
-> (SpanInFlight
    -> IO (Either err (LanguageContextEnv config, IdeState)))
-> IO (Either err (LanguageContextEnv config, IdeState))
forall a b. (a -> b) -> a -> b
$ \SpanInFlight
sp -> do
            SpanInFlight -> InitializeParams -> IO ()
forall a. HasTracing a => SpanInFlight -> a -> IO ()
traceWithSpan SpanInFlight
sp MessageParams 'Initialize
InitializeParams
params
            let root :: Maybe FilePath
root = LanguageContextEnv config -> Maybe FilePath
forall config. LanguageContextEnv config -> Maybe FilePath
LSP.resRootPath LanguageContextEnv config
env

            FilePath
dir <- IO FilePath
forall (m :: * -> *). MonadIO m => m FilePath
getCurrentDirectory
            FilePath
dbLoc <- FilePath -> IO FilePath
getHieDbLoc FilePath
dir

            -- The database needs to be open for the duration of the reactor thread, but we need to pass in a reference

            -- to 'getIdeState', so we use this dirty trick

            MVar (HieDb, IndexQueue)
dbMVar <- IO (MVar (HieDb, IndexQueue))
forall (m :: * -> *) a. MonadIO m => m (MVar a)
newEmptyMVar
            ~(HieDb
hiedb,IndexQueue
hieChan) <- IO (HieDb, IndexQueue) -> IO (HieDb, IndexQueue)
forall a. IO a -> IO a
unsafeInterleaveIO (IO (HieDb, IndexQueue) -> IO (HieDb, IndexQueue))
-> IO (HieDb, IndexQueue) -> IO (HieDb, IndexQueue)
forall a b. (a -> b) -> a -> b
$ MVar (HieDb, IndexQueue) -> IO (HieDb, IndexQueue)
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
takeMVar MVar (HieDb, IndexQueue)
dbMVar

            IdeState
ide <- LanguageContextEnv config
-> VFSHandle
-> Maybe FilePath
-> HieDb
-> IndexQueue
-> IO IdeState
getIdeState LanguageContextEnv config
env (LanguageContextEnv config -> VFSHandle
forall c. LanguageContextEnv c -> VFSHandle
makeLSPVFSHandle LanguageContextEnv config
env) Maybe FilePath
root HieDb
hiedb IndexQueue
hieChan

            let initConfig :: IdeConfiguration
initConfig = InitializeParams -> IdeConfiguration
parseConfiguration MessageParams 'Initialize
InitializeParams
params
            Logger -> Text -> IO ()
logInfo (IdeState -> Logger
ideLogger IdeState
ide) (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ FilePath
"Registering ide configuration: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> IdeConfiguration -> FilePath
forall a. Show a => a -> FilePath
show IdeConfiguration
initConfig
            ShakeExtras -> IdeConfiguration -> IO ()
registerIdeConfiguration (IdeState -> ShakeExtras
shakeExtras IdeState
ide) IdeConfiguration
initConfig

            ThreadId
_ <- (IO () -> (Either SomeException () -> IO ()) -> IO ThreadId)
-> (Either SomeException () -> IO ()) -> IO () -> IO ThreadId
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO () -> (Either SomeException () -> IO ()) -> IO ThreadId
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (Either SomeException a -> m ()) -> m ThreadId
forkFinally (IO () -> Either SomeException () -> IO ()
forall a b. a -> b -> a
const IO ()
exitClientMsg) (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ FilePath -> (HieDb -> IndexQueue -> IO ()) -> IO ()
runWithDb FilePath
dbLoc ((HieDb -> IndexQueue -> IO ()) -> IO ())
-> (HieDb -> IndexQueue -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HieDb
hiedb IndexQueue
hieChan -> do
              MVar (HieDb, IndexQueue) -> (HieDb, IndexQueue) -> IO ()
forall (m :: * -> *) a. MonadIO m => MVar a -> a -> m ()
putMVar MVar (HieDb, IndexQueue)
dbMVar (HieDb
hiedb,IndexQueue
hieChan)
              IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                ReactorMessage
msg <- Chan ReactorMessage -> IO ReactorMessage
forall (m :: * -> *) a. MonadIO m => Chan a -> m a
readChan Chan ReactorMessage
clientMsgChan
                -- We dispatch notifications synchronously and requests asynchronously

                -- This is to ensure that all file edits and config changes are applied before a request is handled

                case ReactorMessage
msg of
                    ReactorNotification IO ()
act -> do
                      IO () -> (SomeException -> IO ()) -> IO ()
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
catch IO ()
act ((SomeException -> IO ()) -> IO ())
-> (SomeException -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(SomeException
e :: SomeException) ->
                        Logger -> Text -> IO ()
logError (IdeState -> Logger
ideLogger IdeState
ide) (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$
                          FilePath
"Unexpected exception on notification, please report!\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                          FilePath
"Exception: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ SomeException -> FilePath
forall a. Show a => a -> FilePath
show SomeException
e
                    ReactorRequest SomeLspId
_id IO ()
act ResponseError -> IO ()
k -> IO (Async ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Async ()) -> IO ()) -> IO (Async ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO (Async ())
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$
                      IdeState
-> (SomeLspId -> IO ())
-> (SomeLspId -> IO ())
-> SomeLspId
-> IO ()
-> (ResponseError -> IO ())
-> IO ()
checkCancelled IdeState
ide SomeLspId -> IO ()
clearReqId SomeLspId -> IO ()
waitForCancel SomeLspId
_id IO ()
act ResponseError -> IO ()
k
            Either err (LanguageContextEnv config, IdeState)
-> IO (Either err (LanguageContextEnv config, IdeState))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either err (LanguageContextEnv config, IdeState)
 -> IO (Either err (LanguageContextEnv config, IdeState)))
-> Either err (LanguageContextEnv config, IdeState)
-> IO (Either err (LanguageContextEnv config, IdeState))
forall a b. (a -> b) -> a -> b
$ (LanguageContextEnv config, IdeState)
-> Either err (LanguageContextEnv config, IdeState)
forall a b. b -> Either a b
Right (LanguageContextEnv config
env,IdeState
ide)

        checkCancelled
          :: IdeState -> (SomeLspId -> IO ()) -> (SomeLspId -> IO ()) -> SomeLspId
          -> IO () -> (ResponseError -> IO ()) -> IO ()
        checkCancelled :: IdeState
-> (SomeLspId -> IO ())
-> (SomeLspId -> IO ())
-> SomeLspId
-> IO ()
-> (ResponseError -> IO ())
-> IO ()
checkCancelled IdeState
ide SomeLspId -> IO ()
clearReqId SomeLspId -> IO ()
waitForCancel SomeLspId
_id IO ()
act ResponseError -> IO ()
k =
            (IO () -> IO () -> IO ()) -> IO () -> IO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO () -> IO () -> IO ()
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
finally (SomeLspId -> IO ()
clearReqId SomeLspId
_id) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                IO () -> (SomeException -> IO ()) -> IO ()
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
catch (do
                    -- We could optimize this by first checking if the id

                    -- is in the cancelled set. However, this is unlikely to be a

                    -- bottleneck and the additional check might hide

                    -- issues with async exceptions that need to be fixed.

                    Either () ()
cancelOrRes <- IO () -> IO () -> IO (Either () ())
forall (m :: * -> *) a b.
MonadUnliftIO m =>
m a -> m b -> m (Either a b)
race (SomeLspId -> IO ()
waitForCancel SomeLspId
_id) IO ()
act
                    case Either () ()
cancelOrRes of
                        Left () -> do
                            Logger -> Text -> IO ()
logDebug (IdeState -> Logger
ideLogger IdeState
ide) (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ FilePath
"Cancelled request " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> SomeLspId -> FilePath
forall a. Show a => a -> FilePath
show SomeLspId
_id
                            ResponseError -> IO ()
k (ResponseError -> IO ()) -> ResponseError -> IO ()
forall a b. (a -> b) -> a -> b
$ ErrorCode -> Text -> Maybe Value -> ResponseError
ResponseError ErrorCode
RequestCancelled Text
"" Maybe Value
forall a. Maybe a
Nothing
                        Right ()
res -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
res
                ) ((SomeException -> IO ()) -> IO ())
-> (SomeException -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(SomeException
e :: SomeException) -> do
                    Logger -> Text -> IO ()
logError (IdeState -> Logger
ideLogger IdeState
ide) (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$
                        FilePath
"Unexpected exception on request, please report!\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                        FilePath
"Exception: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ SomeException -> FilePath
forall a. Show a => a -> FilePath
show SomeException
e
                    ResponseError -> IO ()
k (ResponseError -> IO ()) -> ResponseError -> IO ()
forall a b. (a -> b) -> a -> b
$ ErrorCode -> Text -> Maybe Value -> ResponseError
ResponseError ErrorCode
InternalError (FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ SomeException -> FilePath
forall a. Show a => a -> FilePath
show SomeException
e) Maybe Value
forall a. Maybe a
Nothing


cancelHandler :: (SomeLspId -> IO ()) -> LSP.Handlers (ServerM c)
cancelHandler :: (SomeLspId -> IO ()) -> Handlers (ServerM c)
cancelHandler SomeLspId -> IO ()
cancelRequest = SMethod 'CancelRequest
-> Handler (ServerM c) 'CancelRequest -> Handlers (ServerM c)
forall (m :: Method 'FromClient 'Notification) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
LSP.notificationHandler SMethod 'CancelRequest
forall (f :: From). SMethod 'CancelRequest
SCancelRequest (Handler (ServerM c) 'CancelRequest -> Handlers (ServerM c))
-> Handler (ServerM c) 'CancelRequest -> Handlers (ServerM c)
forall a b. (a -> b) -> a -> b
$ \NotificationMessage{$sel:_params:NotificationMessage :: forall (f :: From) (m :: Method f 'Notification).
NotificationMessage m -> MessageParams m
_params=CancelParams{_id}} ->
  IO () -> ReaderT (Chan ReactorMessage, IdeState) (LspM c) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT (Chan ReactorMessage, IdeState) (LspM c) ())
-> IO () -> ReaderT (Chan ReactorMessage, IdeState) (LspM c) ()
forall a b. (a -> b) -> a -> b
$ SomeLspId -> IO ()
cancelRequest (LspId m -> SomeLspId
forall (f :: From) (m :: Method f 'Request). LspId m -> SomeLspId
SomeLspId LspId m
_id)

exitHandler :: IO () -> LSP.Handlers (ServerM c)
exitHandler :: IO () -> Handlers (ServerM c)
exitHandler IO ()
exit = SMethod 'Exit -> Handler (ServerM c) 'Exit -> Handlers (ServerM c)
forall (m :: Method 'FromClient 'Notification) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
LSP.notificationHandler SMethod 'Exit
SExit (ReaderT (Chan ReactorMessage, IdeState) (LspM c) ()
-> NotificationMessage 'Exit
-> ReaderT (Chan ReactorMessage, IdeState) (LspM c) ()
forall a b. a -> b -> a
const (ReaderT (Chan ReactorMessage, IdeState) (LspM c) ()
 -> NotificationMessage 'Exit
 -> ReaderT (Chan ReactorMessage, IdeState) (LspM c) ())
-> ReaderT (Chan ReactorMessage, IdeState) (LspM c) ()
-> NotificationMessage 'Exit
-> ReaderT (Chan ReactorMessage, IdeState) (LspM c) ()
forall a b. (a -> b) -> a -> b
$ IO () -> ReaderT (Chan ReactorMessage, IdeState) (LspM c) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
exit)

modifyOptions :: LSP.Options -> LSP.Options
modifyOptions :: Options -> Options
modifyOptions Options
x = Options
x{ textDocumentSync :: Maybe TextDocumentSyncOptions
LSP.textDocumentSync   = TextDocumentSyncOptions -> Maybe TextDocumentSyncOptions
forall a. a -> Maybe a
Just (TextDocumentSyncOptions -> Maybe TextDocumentSyncOptions)
-> TextDocumentSyncOptions -> Maybe TextDocumentSyncOptions
forall a b. (a -> b) -> a -> b
$ TextDocumentSyncOptions -> TextDocumentSyncOptions
tweakTDS TextDocumentSyncOptions
origTDS
                   }
    where
        tweakTDS :: TextDocumentSyncOptions -> TextDocumentSyncOptions
tweakTDS TextDocumentSyncOptions
tds = TextDocumentSyncOptions
tds{$sel:_openClose:TextDocumentSyncOptions :: Maybe Bool
_openClose=Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True, $sel:_change:TextDocumentSyncOptions :: Maybe TextDocumentSyncKind
_change=TextDocumentSyncKind -> Maybe TextDocumentSyncKind
forall a. a -> Maybe a
Just TextDocumentSyncKind
TdSyncIncremental, $sel:_save:TextDocumentSyncOptions :: Maybe (Bool |? SaveOptions)
_save=(Bool |? SaveOptions) -> Maybe (Bool |? SaveOptions)
forall a. a -> Maybe a
Just ((Bool |? SaveOptions) -> Maybe (Bool |? SaveOptions))
-> (Bool |? SaveOptions) -> Maybe (Bool |? SaveOptions)
forall a b. (a -> b) -> a -> b
$ SaveOptions -> Bool |? SaveOptions
forall a b. b -> a |? b
InR (SaveOptions -> Bool |? SaveOptions)
-> SaveOptions -> Bool |? SaveOptions
forall a b. (a -> b) -> a -> b
$ Maybe Bool -> SaveOptions
SaveOptions Maybe Bool
forall a. Maybe a
Nothing}
        origTDS :: TextDocumentSyncOptions
origTDS = TextDocumentSyncOptions
-> Maybe TextDocumentSyncOptions -> TextDocumentSyncOptions
forall a. a -> Maybe a -> a
fromMaybe TextDocumentSyncOptions
tdsDefault (Maybe TextDocumentSyncOptions -> TextDocumentSyncOptions)
-> Maybe TextDocumentSyncOptions -> TextDocumentSyncOptions
forall a b. (a -> b) -> a -> b
$ Options -> Maybe TextDocumentSyncOptions
LSP.textDocumentSync Options
x
        tdsDefault :: TextDocumentSyncOptions
tdsDefault = Maybe Bool
-> Maybe TextDocumentSyncKind
-> Maybe Bool
-> Maybe Bool
-> Maybe (Bool |? SaveOptions)
-> TextDocumentSyncOptions
TextDocumentSyncOptions Maybe Bool
forall a. Maybe a
Nothing Maybe TextDocumentSyncKind
forall a. Maybe a
Nothing Maybe Bool
forall a. Maybe a
Nothing Maybe Bool
forall a. Maybe a
Nothing Maybe (Bool |? SaveOptions)
forall a. Maybe a
Nothing