-- 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
    , Log(..)
    ) where

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

import           Development.IDE.Core.IdeConfiguration
import           Development.IDE.Core.Shake            hiding (Log)
import           Development.IDE.Core.Tracing
import           Development.IDE.LSP.HoverDefinition
import           Development.IDE.Types.Logger

import           Control.Monad.IO.Unlift               (MonadUnliftIO)
import qualified Development.IDE.Session               as Session
import qualified Development.IDE.Types.Logger          as Logger
import           Development.IDE.Types.Shake           (WithHieDb)
import           System.IO.Unsafe                      (unsafeInterleaveIO)

data Log
  = LogRegisteringIdeConfig !IdeConfiguration
  | LogReactorThreadException !SomeException
  | LogReactorMessageActionException !SomeException
  | LogReactorThreadStopped
  | LogCancelledRequest !SomeLspId
  | LogSession Session.Log
  deriving Int -> Log -> ShowS
[Log] -> ShowS
Log -> String
(Int -> Log -> ShowS)
-> (Log -> String) -> ([Log] -> ShowS) -> Show Log
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Log] -> ShowS
$cshowList :: [Log] -> ShowS
show :: Log -> String
$cshow :: Log -> String
showsPrec :: Int -> Log -> ShowS
$cshowsPrec :: Int -> Log -> ShowS
Show

instance Pretty Log where
  pretty :: Log -> Doc ann
pretty = \case
    LogRegisteringIdeConfig IdeConfiguration
ideConfig ->
      Doc ann
"Registering IDE configuration:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> IdeConfiguration -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow IdeConfiguration
ideConfig
    LogReactorThreadException SomeException
e ->
      [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat
        [ Doc ann
"ReactorThreadException"
        , String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String -> Doc ann) -> String -> Doc ann
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
e ]
    LogReactorMessageActionException SomeException
e ->
      [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat
        [ Doc ann
"ReactorMessageActionException"
        , String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String -> Doc ann) -> String -> Doc ann
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
e ]
    Log
LogReactorThreadStopped ->
      Doc ann
"Reactor thread stopped"
    LogCancelledRequest SomeLspId
requestId ->
      Doc ann
"Cancelled request" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> SomeLspId -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow SomeLspId
requestId
    LogSession Log
log -> Log -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Log
log

-- used to smuggle RankNType WithHieDb through dbMVar
newtype WithHieDbShield = WithHieDbShield WithHieDb

runLanguageServer
    :: forall config. (Show config)
    => Recorder (WithPriority Log)
    -> LSP.Options
    -> Handle -- input
    -> Handle -- output
    -> (FilePath -> IO FilePath) -- ^ Map root paths to the location of the hiedb for the project
    -> config
    -> (config -> Value -> Either T.Text config)
    -> LSP.Handlers (ServerM config)
    -> (LSP.LanguageContextEnv config -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState)
    -> IO ()
runLanguageServer :: Recorder (WithPriority Log)
-> Options
-> Handle
-> Handle
-> (String -> IO String)
-> config
-> (config -> Value -> Either Text config)
-> Handlers (ServerM config)
-> (LanguageContextEnv config
    -> Maybe String -> WithHieDb -> IndexQueue -> IO IdeState)
-> IO ()
runLanguageServer Recorder (WithPriority Log)
recorder Options
options Handle
inH Handle
outH String -> IO String
getHieDbLoc config
defaultConfig config -> Value -> Either Text config
onConfigurationChange Handlers (ServerM config)
userHandlers LanguageContextEnv config
-> Maybe String -> WithHieDb -> IndexQueue -> IO IdeState
getIdeState = do

    -- This MVar becomes full when the server thread exits or we receive exit message from client.
    -- LSP server will be canceled when it's full.
    MVar ()
clientMsgVar <- IO (MVar ())
forall (m :: * -> *) a. MonadIO m => m (MVar a)
newEmptyMVar
    -- Forcefully exit
    let exit :: IO ()
exit = IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ MVar () -> () -> IO Bool
forall (m :: * -> *) a. MonadIO m => MVar a -> a -> m Bool
tryPutMVar MVar ()
clientMsgVar ()

    -- An MVar to control the lifetime of the reactor loop.
    -- The loop will be stopped and resources freed when it's full
    MVar ()
reactorLifetime <- IO (MVar ())
forall (m :: * -> *) a. MonadIO m => m (MVar a)
newEmptyMVar
    let stopReactorLoop :: IO ()
stopReactorLoop = IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ MVar () -> () -> IO Bool
forall (m :: * -> *) a. MonadIO m => MVar a -> a -> m Bool
tryPutMVar MVar ()
reactorLifetime ()

    -- 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
          ]

    -- 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
          , IO () -> Handlers (ServerM config)
forall c. IO () -> Handlers (ServerM c)
shutdownHandler IO ()
stopReactorLoop
          ]
          -- 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.
config
-> (config -> Value -> Either Text config)
-> (LanguageContextEnv config
    -> Message 'Initialize -> IO (Either ResponseError a))
-> Handlers m
-> (a -> m <~> IO)
-> Options
-> ServerDefinition config
LSP.ServerDefinition
            { onConfigurationChange :: config -> Value -> Either Text config
LSP.onConfigurationChange = config -> Value -> Either Text config
onConfigurationChange
            , defaultConfig :: config
LSP.defaultConfig = config
defaultConfig
            , doInitialize :: LanguageContextEnv config
-> Message 'Initialize
-> IO (Either ResponseError (LanguageContextEnv config, IdeState))
LSP.doInitialize = MVar ()
-> IO ()
-> (SomeLspId -> IO ())
-> (SomeLspId -> IO ())
-> Chan ReactorMessage
-> LanguageContextEnv config
-> RequestMessage 'Initialize
-> IO (Either ResponseError (LanguageContextEnv config, IdeState))
forall err.
MVar ()
-> IO ()
-> (SomeLspId -> IO ())
-> (SomeLspId -> IO ())
-> Chan ReactorMessage
-> LanguageContextEnv config
-> RequestMessage 'Initialize
-> IO (Either err (LanguageContextEnv config, IdeState))
handleInit MVar ()
reactorLifetime 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 () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ MVar () -> IO () -> IO ()
forall (m :: * -> *). MonadUnliftIO m => MVar () -> m () -> m ()
untilMVar MVar ()
clientMsgVar (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          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
inH
            Handle
outH
            ServerDefinition config
serverDefinition

    where
        log :: Logger.Priority -> Log -> IO ()
        log :: Priority -> Log -> IO ()
log = Recorder (WithPriority Log) -> Priority -> Log -> IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder

        handleInit
          :: MVar () -> IO () -> (SomeLspId -> IO ()) -> (SomeLspId -> IO ()) -> Chan ReactorMessage
          -> LSP.LanguageContextEnv config -> RequestMessage Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState))
        handleInit :: MVar ()
-> IO ()
-> (SomeLspId -> IO ())
-> (SomeLspId -> IO ())
-> Chan ReactorMessage
-> LanguageContextEnv config
-> RequestMessage 'Initialize
-> IO (Either err (LanguageContextEnv config, IdeState))
handleInit MVar ()
lifetime IO ()
exitClientMsg SomeLspId -> IO ()
clearReqId SomeLspId -> IO ()
waitForCancel Chan ReactorMessage
clientMsgChan LanguageContextEnv config
env (RequestMessage Text
_ LspId 'Initialize
_ SMethod 'Initialize
m MessageParams 'Initialize
params) = String
-> String
-> (SpanInFlight
    -> IO (Either err (LanguageContextEnv config, IdeState)))
-> IO (Either err (LanguageContextEnv config, IdeState))
forall (m :: * -> *) a.
MonadUnliftIO m =>
String -> String -> (SpanInFlight -> m a) -> m a
otTracedHandler String
"Initialize" (SMethod 'Initialize -> String
forall a. Show a => a -> String
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 String
root = LanguageContextEnv config -> Maybe String
forall config. LanguageContextEnv config -> Maybe String
LSP.resRootPath LanguageContextEnv config
env
            String
dir <- IO String -> (String -> IO String) -> Maybe String -> IO String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO String
forall (m :: * -> *). MonadIO m => m String
getCurrentDirectory String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
root
            String
dbLoc <- String -> IO String
getHieDbLoc String
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 (WithHieDbShield, IndexQueue)
dbMVar <- IO (MVar (WithHieDbShield, IndexQueue))
forall (m :: * -> *) a. MonadIO m => m (MVar a)
newEmptyMVar
            ~(WithHieDbShield WithHieDb
withHieDb,IndexQueue
hieChan) <- IO (WithHieDbShield, IndexQueue)
-> IO (WithHieDbShield, IndexQueue)
forall a. IO a -> IO a
unsafeInterleaveIO (IO (WithHieDbShield, IndexQueue)
 -> IO (WithHieDbShield, IndexQueue))
-> IO (WithHieDbShield, IndexQueue)
-> IO (WithHieDbShield, IndexQueue)
forall a b. (a -> b) -> a -> b
$ MVar (WithHieDbShield, IndexQueue)
-> IO (WithHieDbShield, IndexQueue)
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
takeMVar MVar (WithHieDbShield, IndexQueue)
dbMVar

            IdeState
ide <- LanguageContextEnv config
-> Maybe String -> WithHieDb -> IndexQueue -> IO IdeState
getIdeState LanguageContextEnv config
env Maybe String
root WithHieDb
withHieDb IndexQueue
hieChan

            let initConfig :: IdeConfiguration
initConfig = InitializeParams -> IdeConfiguration
parseConfiguration MessageParams 'Initialize
InitializeParams
params

            Priority -> Log -> IO ()
log Priority
Info (Log -> IO ()) -> Log -> IO ()
forall a b. (a -> b) -> a -> b
$ IdeConfiguration -> Log
LogRegisteringIdeConfig IdeConfiguration
initConfig
            ShakeExtras -> IdeConfiguration -> IO ()
registerIdeConfiguration (IdeState -> ShakeExtras
shakeExtras IdeState
ide) IdeConfiguration
initConfig

            let handleServerException :: Either SomeException () -> IO ()
handleServerException (Left SomeException
e) = do
                    Priority -> Log -> IO ()
log Priority
Error (Log -> IO ()) -> Log -> IO ()
forall a b. (a -> b) -> a -> b
$ SomeException -> Log
LogReactorThreadException SomeException
e
                    IO ()
exitClientMsg
                handleServerException (Right ()
_) = () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

                exceptionInHandler :: SomeException -> IO ()
exceptionInHandler SomeException
e = do
                    Priority -> Log -> IO ()
log Priority
Error (Log -> IO ()) -> Log -> IO ()
forall a b. (a -> b) -> a -> b
$ SomeException -> Log
LogReactorMessageActionException SomeException
e

                checkCancelled :: SomeLspId -> IO () -> (ResponseError -> IO ()) -> IO ()
checkCancelled 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
                                    Priority -> Log -> IO ()
log Priority
Debug (Log -> IO ()) -> Log -> IO ()
forall a b. (a -> b) -> a -> b
$ SomeLspId -> Log
LogCancelledRequest 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
                            SomeException -> IO ()
exceptionInHandler SomeException
e
                            ResponseError -> IO ()
k (ResponseError -> IO ()) -> ResponseError -> IO ()
forall a b. (a -> b) -> a -> b
$ ErrorCode -> Text -> Maybe Value -> ResponseError
ResponseError ErrorCode
InternalError (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall a. Show a => a -> String
show SomeException
e) Maybe Value
forall a. Maybe a
Nothing
            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 Either SomeException () -> IO ()
handleServerException (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
                MVar () -> IO () -> IO ()
forall (m :: * -> *). MonadUnliftIO m => MVar () -> m () -> m ()
untilMVar MVar ()
lifetime (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Recorder (WithPriority Log)
-> String -> (WithHieDb -> IndexQueue -> IO ()) -> IO ()
runWithDb ((Log -> Log)
-> Recorder (WithPriority Log) -> Recorder (WithPriority Log)
forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogSession Recorder (WithPriority Log)
recorder) String
dbLoc ((WithHieDb -> IndexQueue -> IO ()) -> IO ())
-> (WithHieDb -> IndexQueue -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \WithHieDb
withHieDb IndexQueue
hieChan -> do
                    MVar (WithHieDbShield, IndexQueue)
-> (WithHieDbShield, IndexQueue) -> IO ()
forall (m :: * -> *) a. MonadIO m => MVar a -> a -> m ()
putMVar MVar (WithHieDbShield, IndexQueue)
dbMVar (WithHieDb -> WithHieDbShield
WithHieDbShield WithHieDb
withHieDb,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 -> (SomeException -> IO ()) -> IO () -> IO ()
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
(e -> m a) -> m a -> m a
handle SomeException -> IO ()
exceptionInHandler IO ()
act
                            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
$ SomeLspId -> IO () -> (ResponseError -> IO ()) -> IO ()
checkCancelled SomeLspId
_id IO ()
act ResponseError -> IO ()
k
                Priority -> Log -> IO ()
log Priority
Info Log
LogReactorThreadStopped
            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)


-- | Runs the action until it ends or until the given MVar is put.
--   Rethrows any exceptions.
untilMVar :: MonadUnliftIO m => MVar () -> m () -> m ()
untilMVar :: MVar () -> m () -> m ()
untilMVar MVar ()
mvar m ()
io = m (Async (), ()) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Async (), ()) -> m ()) -> m (Async (), ()) -> m ()
forall a b. (a -> b) -> a -> b
$
    [Async ()] -> m (Async (), ())
forall (m :: * -> *) a. MonadIO m => [Async a] -> m (Async a, a)
waitAnyCancel ([Async ()] -> m (Async (), ()))
-> m [Async ()] -> m (Async (), ())
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (m () -> m (Async ())) -> [m ()] -> m [Async ()]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse m () -> m (Async ())
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async [ m ()
io , MVar () -> m ()
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
readMVar MVar ()
mvar ]

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)

shutdownHandler :: IO () -> LSP.Handlers (ServerM c)
shutdownHandler :: IO () -> Handlers (ServerM c)
shutdownHandler IO ()
stopReactor = SMethod 'Shutdown
-> Handler (ServerM c) 'Shutdown -> Handlers (ServerM c)
forall (m :: Method 'FromClient 'Request) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
LSP.requestHandler SMethod 'Shutdown
SShutdown (Handler (ServerM c) 'Shutdown -> Handlers (ServerM c))
-> Handler (ServerM c) 'Shutdown -> Handlers (ServerM c)
forall a b. (a -> b) -> a -> b
$ \RequestMessage 'Shutdown
_ Either ResponseError Empty
-> ReaderT (Chan ReactorMessage, IdeState) (LspM c) ()
resp -> do
    (Chan ReactorMessage
_, IdeState
ide) <- ReaderT
  (Chan ReactorMessage, IdeState)
  (LspM c)
  (Chan ReactorMessage, IdeState)
forall r (m :: * -> *). MonadReader r m => m r
ask
    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
$ Logger -> Text -> IO ()
logDebug (IdeState -> Logger
ideLogger IdeState
ide) Text
"Received shutdown message"
    -- stop the reactor to free up the hiedb connection
    IO () -> ReaderT (Chan ReactorMessage, IdeState) (LspM c) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
stopReactor
    -- flush out the Shake session to record a Shake profile if applicable
    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
$ IdeState -> IO ()
shakeShut IdeState
ide
    Either ResponseError Empty
-> ReaderT (Chan ReactorMessage, IdeState) (LspM c) ()
resp (Either ResponseError Empty
 -> ReaderT (Chan ReactorMessage, IdeState) (LspM c) ())
-> Either ResponseError Empty
-> ReaderT (Chan ReactorMessage, IdeState) (LspM c) ()
forall a b. (a -> b) -> a -> b
$ Empty -> Either ResponseError Empty
forall a b. b -> Either a b
Right Empty
Empty

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 (Handler (ServerM c) 'Exit -> Handlers (ServerM c))
-> Handler (ServerM c) 'Exit -> Handlers (ServerM c)
forall a b. (a -> b) -> a -> b
$ 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