-- Copyright (c) 2019 The DAML Authors. All rights reserved.
-- SPDX-License-Identifier: Apache-2.0

{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs                 #-}
-- 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
    , setupLSP
    , Log(..)
    , ThreadQueue
    , runWithWorkerThreads
    ) 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           Language.LSP.Protocol.Message
import           Language.LSP.Protocol.Types
import qualified Language.LSP.Server                   as LSP
import           System.IO
import           UnliftIO.Async
import           UnliftIO.Concurrent
import           UnliftIO.Directory
import           UnliftIO.Exception

import qualified Colog.Core                            as Colog
import           Control.Monad.IO.Unlift               (MonadUnliftIO)
import           Control.Monad.Trans.Cont              (evalContT)
import           Development.IDE.Core.IdeConfiguration
import           Development.IDE.Core.Shake            hiding (Log)
import           Development.IDE.Core.Tracing
import           Development.IDE.Core.WorkerThread     (withWorkerQueue)
import qualified Development.IDE.Session               as Session
import           Development.IDE.Types.Shake           (WithHieDb,
                                                        WithHieDbShield (..))
import           Ide.Logger
import           Language.LSP.Server                   (LanguageContextEnv,
                                                        LspServerLog,
                                                        type (<~>))
data Log
  = LogRegisteringIdeConfig !IdeConfiguration
  | LogReactorThreadException !SomeException
  | LogReactorMessageActionException !SomeException
  | LogReactorThreadStopped
  | LogCancelledRequest !SomeLspId
  | LogSession Session.Log
  | LogLspServer LspServerLog
  | LogServerShutdownMessage
  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
$cshowsPrec :: Int -> Log -> ShowS
showsPrec :: Int -> Log -> ShowS
$cshow :: Log -> String
show :: Log -> String
$cshowList :: [Log] -> ShowS
showList :: [Log] -> ShowS
Show

instance Pretty Log where
  pretty :: forall ann. Log -> Doc ann
pretty = \case
    LogRegisteringIdeConfig IdeConfiguration
ideConfig ->
      -- This log is also used to identify if HLS starts successfully in vscode-haskell,
      -- don't forget to update the corresponding test in vscode-haskell if the text in
      -- the next line has been modified.
      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 ann. 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 ann. 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
msg -> Log -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Log -> Doc ann
pretty Log
msg
    LogLspServer LspServerLog
msg -> LspServerLog -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. LspServerLog -> Doc ann
pretty LspServerLog
msg
    Log
LogServerShutdownMessage -> Doc ann
"Received shutdown message"


runLanguageServer
    :: forall config a m. (Show config)
    => Recorder (WithPriority Log)
    -> LSP.Options
    -> Handle -- input
    -> Handle -- output
    -> config
    -> (config -> Value -> Either T.Text config)
    -> (config -> m config ())
    -> (MVar ()
        -> IO (LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either (TResponseError Method_Initialize) (LSP.LanguageContextEnv config, a)),
               LSP.Handlers (m config),
               (LanguageContextEnv config, a) -> m config <~> IO))
    -> IO ()
runLanguageServer :: forall config a (m :: * -> * -> *).
Show config =>
Recorder (WithPriority Log)
-> Options
-> Handle
-> Handle
-> config
-> (config -> Value -> Either Text config)
-> (config -> m config ())
-> (MVar ()
    -> IO
         (LanguageContextEnv config
          -> TRequestMessage 'Method_Initialize
          -> IO
               (Either
                  (TResponseError 'Method_Initialize)
                  (LanguageContextEnv config, a)),
          Handlers (m config),
          (LanguageContextEnv config, a) -> m config <~> IO))
-> IO ()
runLanguageServer Recorder (WithPriority Log)
recorder Options
options Handle
inH Handle
outH config
defaultConfig config -> Value -> Either Text config
parseConfig config -> m config ()
onConfigChange MVar ()
-> IO
     (LanguageContextEnv config
      -> TRequestMessage 'Method_Initialize
      -> IO
           (Either
              (TResponseError 'Method_Initialize)
              (LanguageContextEnv config, a)),
      Handlers (m config),
      (LanguageContextEnv config, a) -> m config <~> IO)
setup = 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

    (LanguageContextEnv config
-> TRequestMessage 'Method_Initialize
-> IO
     (Either
        (TResponseError 'Method_Initialize) (LanguageContextEnv config, a))
doInitialize, Handlers (m config)
staticHandlers, (LanguageContextEnv config, a) -> m config <~> IO
interpretHandler) <- MVar ()
-> IO
     (LanguageContextEnv config
      -> TRequestMessage 'Method_Initialize
      -> IO
           (Either
              (TResponseError 'Method_Initialize)
              (LanguageContextEnv config, a)),
      Handlers (m config),
      (LanguageContextEnv config, a) -> m config <~> IO)
setup MVar ()
clientMsgVar

    let serverDefinition :: ServerDefinition config
serverDefinition = LSP.ServerDefinition
            { parseConfig :: config -> Value -> Either Text config
LSP.parseConfig = config -> Value -> Either Text config
parseConfig
            , onConfigChange :: config -> m config ()
LSP.onConfigChange = config -> m config ()
onConfigChange
            , defaultConfig :: config
LSP.defaultConfig = config
defaultConfig
            -- TODO: magic string
            , configSection :: Text
LSP.configSection = Text
"haskell"
            , doInitialize :: LanguageContextEnv config
-> TMessage 'Method_Initialize
-> IO
     (Either
        (TResponseError 'Method_Initialize) (LanguageContextEnv config, a))
LSP.doInitialize = LanguageContextEnv config
-> TRequestMessage 'Method_Initialize
-> IO
     (Either
        (TResponseError 'Method_Initialize) (LanguageContextEnv config, a))
LanguageContextEnv config
-> TMessage 'Method_Initialize
-> IO
     (Either
        (TResponseError 'Method_Initialize) (LanguageContextEnv config, a))
doInitialize
            , staticHandlers :: ClientCapabilities -> Handlers (m config)
LSP.staticHandlers = Handlers (m config) -> ClientCapabilities -> Handlers (m config)
forall a b. a -> b -> a
const Handlers (m config)
staticHandlers
            , interpretHandler :: (LanguageContextEnv config, a) -> m config <~> IO
LSP.interpretHandler = (LanguageContextEnv config, a) -> m config <~> IO
interpretHandler
            , options :: Options
LSP.options = Options -> Options
modifyOptions Options
options
            }

    let lspCologAction :: MonadIO m2 => Colog.LogAction m2 (Colog.WithSeverity LspServerLog)
        lspCologAction :: forall (m2 :: * -> *).
MonadIO m2 =>
LogAction m2 (WithSeverity LspServerLog)
lspCologAction = Recorder (WithPriority LspServerLog)
-> LogAction m2 (WithSeverity LspServerLog)
forall (m :: * -> *) msg.
(MonadIO m, HasCallStack) =>
Recorder (WithPriority msg) -> LogAction m (WithSeverity msg)
toCologActionWithPrio ((LspServerLog -> Log)
-> Recorder (WithPriority Log)
-> Recorder (WithPriority LspServerLog)
forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio LspServerLog -> Log
LogLspServer Recorder (WithPriority Log)
recorder)

    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
$ LogAction IO (WithSeverity LspServerLog)
-> LogAction (LspM config) (WithSeverity LspServerLog)
-> Handle
-> Handle
-> ServerDefinition config
-> IO Int
forall config.
LogAction IO (WithSeverity LspServerLog)
-> LogAction (LspM config) (WithSeverity LspServerLog)
-> Handle
-> Handle
-> ServerDefinition config
-> IO Int
LSP.runServerWithHandles
            LogAction IO (WithSeverity LspServerLog)
forall (m2 :: * -> *).
MonadIO m2 =>
LogAction m2 (WithSeverity LspServerLog)
lspCologAction
            LogAction (LspM config) (WithSeverity LspServerLog)
forall (m2 :: * -> *).
MonadIO m2 =>
LogAction m2 (WithSeverity LspServerLog)
lspCologAction
            Handle
inH
            Handle
outH
            ServerDefinition config
serverDefinition

setupLSP ::
     forall config err.
     Recorder (WithPriority Log)
  -> FilePath -- ^ root directory, see Note [Root Directory]
  -> (FilePath -> IO FilePath) -- ^ Map root paths to the location of the hiedb for the project
  -> LSP.Handlers (ServerM config)
  -> (LSP.LanguageContextEnv config -> FilePath -> WithHieDb -> ThreadQueue -> IO IdeState)
  -> MVar ()
  -> IO (LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState)),
         LSP.Handlers (ServerM config),
         (LanguageContextEnv config, IdeState) -> ServerM config <~> IO)
setupLSP :: forall config err.
Recorder (WithPriority Log)
-> String
-> (String -> IO String)
-> Handlers (ServerM config)
-> (LanguageContextEnv config
    -> String -> WithHieDb -> ThreadQueue -> IO IdeState)
-> MVar ()
-> IO
     (LanguageContextEnv config
      -> TRequestMessage 'Method_Initialize
      -> IO (Either err (LanguageContextEnv config, IdeState)),
      Handlers (ServerM config),
      (LanguageContextEnv config, IdeState) -> ServerM config <~> IO)
setupLSP Recorder (WithPriority Log)
recorder String
defaultRoot String -> IO String
getHieDbLoc Handlers (ServerM config)
userHandlers LanguageContextEnv config
-> String -> WithHieDb -> ThreadQueue -> IO IdeState
getIdeState MVar ()
clientMsgVar = do
  -- 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

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

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

  -- 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 a. Ord a => a -> Set a -> Bool
`Set.member` 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 asyncHandlers :: Handlers (ServerM config)
asyncHandlers = [Handlers (ServerM config)] -> Handlers (ServerM config)
forall a. Monoid a => [a] -> a
mconcat
        [ Handlers (ServerM config)
userHandlers
        , (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
        , Recorder (WithPriority Log) -> IO () -> Handlers (ServerM config)
forall c.
Recorder (WithPriority Log) -> IO () -> Handlers (ServerM c)
shutdownHandler Recorder (WithPriority Log)
recorder IO ()
stopReactorLoop
        ]
        -- Cancel requests are special since they need to be handled
        -- out of order to be useful. Existing handlers are run afterwards.

  let doInitialize :: LanguageContextEnv config
-> TRequestMessage 'Method_Initialize
-> IO (Either err (LanguageContextEnv config, IdeState))
doInitialize = Recorder (WithPriority Log)
-> String
-> (String -> IO String)
-> (LanguageContextEnv config
    -> String -> WithHieDb -> ThreadQueue -> IO IdeState)
-> MVar ()
-> IO ()
-> (SomeLspId -> IO ())
-> (SomeLspId -> IO ())
-> Chan ReactorMessage
-> LanguageContextEnv config
-> TRequestMessage 'Method_Initialize
-> IO (Either err (LanguageContextEnv config, IdeState))
forall config err.
Recorder (WithPriority Log)
-> String
-> (String -> IO String)
-> (LanguageContextEnv config
    -> String -> WithHieDb -> ThreadQueue -> IO IdeState)
-> MVar ()
-> IO ()
-> (SomeLspId -> IO ())
-> (SomeLspId -> IO ())
-> Chan ReactorMessage
-> LanguageContextEnv config
-> TRequestMessage 'Method_Initialize
-> IO (Either err (LanguageContextEnv config, IdeState))
handleInit Recorder (WithPriority Log)
recorder String
defaultRoot String -> IO String
getHieDbLoc LanguageContextEnv config
-> String -> WithHieDb -> ThreadQueue -> IO IdeState
getIdeState MVar ()
reactorLifetime IO ()
exit SomeLspId -> IO ()
clearReqId SomeLspId -> IO ()
waitForCancel Chan ReactorMessage
clientMsgChan

  let interpretHandler :: (LanguageContextEnv config, IdeState) -> ServerM config <~> IO
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)
-> (ServerM config a -> LspT config IO a)
-> ServerM config a
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ServerM config a
 -> (Chan ReactorMessage, IdeState) -> LspT config IO a)
-> (Chan ReactorMessage, IdeState)
-> ServerM config 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 (ReaderT (Chan ReactorMessage, IdeState) (LspT config IO) a
 -> (Chan ReactorMessage, IdeState) -> LspT config IO a)
-> (ServerM config a
    -> ReaderT (Chan ReactorMessage, IdeState) (LspT config IO) a)
-> ServerM config a
-> (Chan ReactorMessage, IdeState)
-> LspT config IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerM config a
-> ReaderT (Chan ReactorMessage, IdeState) (LspT config IO) a
forall c a.
ServerM c a -> ReaderT (Chan ReactorMessage, IdeState) (LspM c) a
unServerM) (Chan ReactorMessage
clientMsgChan,IdeState
st)) IO a -> ServerM config a
forall a. IO a -> ServerM config a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO

  (LanguageContextEnv config
 -> TRequestMessage 'Method_Initialize
 -> IO (Either err (LanguageContextEnv config, IdeState)),
 Handlers (ServerM config),
 (LanguageContextEnv config, IdeState) -> ServerM config <~> IO)
-> IO
     (LanguageContextEnv config
      -> TRequestMessage 'Method_Initialize
      -> IO (Either err (LanguageContextEnv config, IdeState)),
      Handlers (ServerM config),
      (LanguageContextEnv config, IdeState) -> ServerM config <~> IO)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LanguageContextEnv config
-> TRequestMessage 'Method_Initialize
-> IO (Either err (LanguageContextEnv config, IdeState))
doInitialize, Handlers (ServerM config)
asyncHandlers, (LanguageContextEnv config, IdeState) -> ServerM config <~> IO
interpretHandler)


handleInit
    :: Recorder (WithPriority Log)
    -> FilePath -- ^ root directory, see Note [Root Directory]
    -> (FilePath -> IO FilePath)
    -> (LSP.LanguageContextEnv config -> FilePath -> WithHieDb -> ThreadQueue -> IO IdeState)
    -> MVar ()
    -> IO ()
    -> (SomeLspId -> IO ())
    -> (SomeLspId -> IO ())
    -> Chan ReactorMessage
    -> LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState))
handleInit :: forall config err.
Recorder (WithPriority Log)
-> String
-> (String -> IO String)
-> (LanguageContextEnv config
    -> String -> WithHieDb -> ThreadQueue -> IO IdeState)
-> MVar ()
-> IO ()
-> (SomeLspId -> IO ())
-> (SomeLspId -> IO ())
-> Chan ReactorMessage
-> LanguageContextEnv config
-> TRequestMessage 'Method_Initialize
-> IO (Either err (LanguageContextEnv config, IdeState))
handleInit Recorder (WithPriority Log)
recorder String
defaultRoot String -> IO String
getHieDbLoc LanguageContextEnv config
-> String -> WithHieDb -> ThreadQueue -> IO IdeState
getIdeState MVar ()
lifetime IO ()
exitClientMsg SomeLspId -> IO ()
clearReqId SomeLspId -> IO ()
waitForCancel Chan ReactorMessage
clientMsgChan LanguageContextEnv config
env (TRequestMessage Text
_ LspId 'Method_Initialize
_ SMethod 'Method_Initialize
m MessageParams 'Method_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 'Method_Initialize -> String
forall a. Show a => a -> String
show SMethod 'Method_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 InitializeParams
MessageParams 'Method_Initialize
params
    -- only shift if lsp root is different from the rootDir
    -- see Note [Root Directory]
    String
root <- case LanguageContextEnv config -> Maybe String
forall config. LanguageContextEnv config -> Maybe String
LSP.resRootPath LanguageContextEnv config
env of
        Just String
lspRoot | String
lspRoot String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
defaultRoot -> String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
setCurrentDirectory String
lspRoot IO () -> IO String -> IO String
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
lspRoot
        Maybe String
_ -> String -> IO String
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
defaultRoot
    String
dbLoc <- String -> IO String
getHieDbLoc String
root
    let initConfig :: IdeConfiguration
initConfig = InitializeParams -> IdeConfiguration
parseConfiguration InitializeParams
MessageParams 'Method_Initialize
params
    Recorder (WithPriority Log) -> Priority -> Log -> IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Info (Log -> IO ()) -> Log -> IO ()
forall a b. (a -> b) -> a -> b
$ IdeConfiguration -> Log
LogRegisteringIdeConfig IdeConfiguration
initConfig
    MVar (WithHieDbShield, ThreadQueue)
dbMVar <- IO (MVar (WithHieDbShield, ThreadQueue))
forall (m :: * -> *) a. MonadIO m => m (MVar a)
newEmptyMVar


    let handleServerException :: Either SomeException () -> IO ()
handleServerException (Left SomeException
e) = do
            Recorder (WithPriority Log) -> Priority -> Log -> IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Error (Log -> IO ()) -> Log -> IO ()
forall a b. (a -> b) -> a -> b
$ SomeException -> Log
LogReactorThreadException SomeException
e
            IO ()
exitClientMsg
        handleServerException (Right ()
_) = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

        exceptionInHandler :: SomeException -> IO ()
exceptionInHandler SomeException
e = do
            Recorder (WithPriority Log) -> Priority -> Log -> IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Error (Log -> IO ()) -> Log -> IO ()
forall a b. (a -> b) -> a -> b
$ SomeException -> Log
LogReactorMessageActionException SomeException
e

        checkCancelled :: forall m . LspId m -> IO () -> (TResponseError m -> IO ()) -> IO ()
        checkCancelled :: forall {f :: MessageDirection} (m :: Method f 'Request).
LspId m -> IO () -> (TResponseError m -> IO ()) -> IO ()
checkCancelled LspId m
_id IO ()
act TResponseError m -> IO ()
k =
            let sid :: SomeLspId
sid = LspId m -> SomeLspId
forall {f :: MessageDirection} (m :: Method f 'Request).
LspId m -> SomeLspId
SomeLspId LspId m
_id
            in (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
sid) (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
sid) IO ()
act
                    case Either () ()
cancelOrRes of
                        Left () -> do
                            Recorder (WithPriority Log) -> Priority -> Log -> IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Debug (Log -> IO ()) -> Log -> IO ()
forall a b. (a -> b) -> a -> b
$ SomeLspId -> Log
LogCancelledRequest SomeLspId
sid
                            TResponseError m -> IO ()
k (TResponseError m -> IO ()) -> TResponseError m -> IO ()
forall a b. (a -> b) -> a -> b
$ (LSPErrorCodes |? ErrorCodes)
-> Text -> Maybe (ErrorData m) -> TResponseError m
forall (f :: MessageDirection) (m :: Method f 'Request).
(LSPErrorCodes |? ErrorCodes)
-> Text -> Maybe (ErrorData m) -> TResponseError m
TResponseError (LSPErrorCodes -> LSPErrorCodes |? ErrorCodes
forall a b. a -> a |? b
InL LSPErrorCodes
LSPErrorCodes_RequestCancelled) Text
"" Maybe (ErrorData m)
forall a. Maybe a
Nothing
                        Right ()
res -> () -> IO ()
forall a. a -> IO a
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
                    TResponseError m -> IO ()
k (TResponseError m -> IO ()) -> TResponseError m -> IO ()
forall a b. (a -> b) -> a -> b
$ (LSPErrorCodes |? ErrorCodes)
-> Text -> Maybe (ErrorData m) -> TResponseError m
forall (f :: MessageDirection) (m :: Method f 'Request).
(LSPErrorCodes |? ErrorCodes)
-> Text -> Maybe (ErrorData m) -> TResponseError m
TResponseError (ErrorCodes -> LSPErrorCodes |? ErrorCodes
forall a b. b -> a |? b
InR ErrorCodes
ErrorCodes_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 (ErrorData m)
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 -> ThreadQueue -> IO ()) -> IO ()
runWithWorkerThreads ((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 -> ThreadQueue -> IO ()) -> IO ())
-> (WithHieDb -> ThreadQueue -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \WithHieDb
withHieDb' ThreadQueue
threadQueue' -> do
            MVar (WithHieDbShield, ThreadQueue)
-> (WithHieDbShield, ThreadQueue) -> IO ()
forall (m :: * -> *) a. MonadIO m => MVar a -> a -> m ()
putMVar MVar (WithHieDbShield, ThreadQueue)
dbMVar (WithHieDb -> WithHieDbShield
WithHieDbShield (HieDb -> IO a) -> IO a
WithHieDb
withHieDb',ThreadQueue
threadQueue')
            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 LspId m
_id IO ()
act TResponseError m -> 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
$ LspId m -> IO () -> (TResponseError m -> IO ()) -> IO ()
forall {f :: MessageDirection} (m :: Method f 'Request).
LspId m -> IO () -> (TResponseError m -> IO ()) -> IO ()
checkCancelled LspId m
_id IO ()
act TResponseError m -> IO ()
k
        Recorder (WithPriority Log) -> Priority -> Log -> IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Info Log
LogReactorThreadStopped

    (WithHieDbShield WithHieDb
withHieDb, ThreadQueue
threadQueue) <- MVar (WithHieDbShield, ThreadQueue)
-> IO (WithHieDbShield, ThreadQueue)
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
takeMVar MVar (WithHieDbShield, ThreadQueue)
dbMVar
    IdeState
ide <- LanguageContextEnv config
-> String -> WithHieDb -> ThreadQueue -> IO IdeState
getIdeState LanguageContextEnv config
env String
root (HieDb -> IO a) -> IO a
WithHieDb
withHieDb ThreadQueue
threadQueue
    ShakeExtras -> IdeConfiguration -> IO ()
registerIdeConfiguration (IdeState -> ShakeExtras
shakeExtras IdeState
ide) IdeConfiguration
initConfig
    Either err (LanguageContextEnv config, IdeState)
-> IO (Either err (LanguageContextEnv config, IdeState))
forall a. a -> IO a
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)


-- | runWithWorkerThreads
-- create several threads to run the session, db and session loader
-- see Note [Serializing runs in separate thread]
runWithWorkerThreads :: Recorder (WithPriority Session.Log) -> FilePath -> (WithHieDb -> ThreadQueue -> IO ()) -> IO ()
runWithWorkerThreads :: Recorder (WithPriority Log)
-> String -> (WithHieDb -> ThreadQueue -> IO ()) -> IO ()
runWithWorkerThreads Recorder (WithPriority Log)
recorder String
dbLoc WithHieDb -> ThreadQueue -> IO ()
f = ContT () IO () -> IO ()
forall (m :: * -> *) r. Monad m => ContT r m r -> m r
evalContT (ContT () IO () -> IO ()) -> ContT () IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            TQueue (IO ())
sessionRestartTQueue <- (IO () -> IO ()) -> ContT () IO (TQueue (IO ()))
forall t a. (t -> IO a) -> ContT () IO (TQueue t)
withWorkerQueue IO () -> IO ()
forall a. a -> a
id
            TQueue (IO ())
sessionLoaderTQueue <- (IO () -> IO ()) -> ContT () IO (TQueue (IO ()))
forall t a. (t -> IO a) -> ContT () IO (TQueue t)
withWorkerQueue IO () -> IO ()
forall a. a -> a
id
            (WithHieDbShield WithHieDb
hiedb, IndexQueue
threadQueue) <- Recorder (WithPriority Log)
-> String -> ContT () IO (WithHieDbShield, IndexQueue)
runWithDb Recorder (WithPriority Log)
recorder String
dbLoc
            IO () -> ContT () IO ()
forall a. IO a -> ContT () IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ContT () IO ()) -> IO () -> ContT () IO ()
forall a b. (a -> b) -> a -> b
$ WithHieDb -> ThreadQueue -> IO ()
f (HieDb -> IO a) -> IO a
WithHieDb
hiedb (IndexQueue -> TQueue (IO ()) -> TQueue (IO ()) -> ThreadQueue
ThreadQueue IndexQueue
threadQueue TQueue (IO ())
sessionRestartTQueue TQueue (IO ())
sessionLoaderTQueue)

-- | Runs the action until it ends or until the given MVar is put.
--   Rethrows any exceptions.
untilMVar :: MonadUnliftIO m => MVar () -> m () -> m ()
untilMVar :: forall (m :: * -> *). MonadUnliftIO m => 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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [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 :: forall c. (SomeLspId -> IO ()) -> Handlers (ServerM c)
cancelHandler SomeLspId -> IO ()
cancelRequest = SMethod 'Method_CancelRequest
-> Handler (ServerM c) 'Method_CancelRequest
-> Handlers (ServerM c)
forall (m :: Method 'ClientToServer 'Notification) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
LSP.notificationHandler SMethod 'Method_CancelRequest
forall {f :: MessageDirection}. SMethod 'Method_CancelRequest
SMethod_CancelRequest (Handler (ServerM c) 'Method_CancelRequest -> Handlers (ServerM c))
-> Handler (ServerM c) 'Method_CancelRequest
-> Handlers (ServerM c)
forall a b. (a -> b) -> a -> b
$ \TNotificationMessage{$sel:_params:TNotificationMessage :: forall (f :: MessageDirection) (m :: Method f 'Notification).
TNotificationMessage m -> MessageParams m
_params=CancelParams{Int32 |? Text
_id :: Int32 |? Text
$sel:_id:CancelParams :: CancelParams -> Int32 |? Text
_id}} ->
  IO () -> ServerM c ()
forall a. IO a -> ServerM c a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ServerM c ()) -> IO () -> ServerM c ()
forall a b. (a -> b) -> a -> b
$ SomeLspId -> IO ()
cancelRequest (LspId Any -> SomeLspId
forall {f :: MessageDirection} (m :: Method f 'Request).
LspId m -> SomeLspId
SomeLspId ((Int32 |? Text) -> LspId Any
forall {f :: MessageDirection} (a :: Method f 'Request).
(Int32 |? Text) -> LspId a
toLspId Int32 |? Text
_id))
  where toLspId :: (Int32 |? T.Text) -> LspId a
        toLspId :: forall {f :: MessageDirection} (a :: Method f 'Request).
(Int32 |? Text) -> LspId a
toLspId (InL Int32
x) = Int32 -> LspId a
forall (f :: MessageDirection) (m :: Method f 'Request).
Int32 -> LspId m
IdInt Int32
x
        toLspId (InR Text
y) = Text -> LspId a
forall (f :: MessageDirection) (m :: Method f 'Request).
Text -> LspId m
IdString Text
y

shutdownHandler :: Recorder (WithPriority Log) -> IO () -> LSP.Handlers (ServerM c)
shutdownHandler :: forall c.
Recorder (WithPriority Log) -> IO () -> Handlers (ServerM c)
shutdownHandler Recorder (WithPriority Log)
recorder IO ()
stopReactor = SMethod 'Method_Shutdown
-> Handler (ServerM c) 'Method_Shutdown -> Handlers (ServerM c)
forall (m :: Method 'ClientToServer 'Request) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
LSP.requestHandler SMethod 'Method_Shutdown
SMethod_Shutdown (Handler (ServerM c) 'Method_Shutdown -> Handlers (ServerM c))
-> Handler (ServerM c) 'Method_Shutdown -> Handlers (ServerM c)
forall a b. (a -> b) -> a -> b
$ \TRequestMessage 'Method_Shutdown
_ Either (TResponseError 'Method_Shutdown) Null -> ServerM c ()
resp -> do
    (Chan ReactorMessage
_, IdeState
ide) <- ServerM c (Chan ReactorMessage, IdeState)
forall r (m :: * -> *). MonadReader r m => m r
ask
    IO () -> ServerM c ()
forall a. IO a -> ServerM c a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ServerM c ()) -> IO () -> ServerM c ()
forall a b. (a -> b) -> a -> b
$ Recorder (WithPriority Log) -> Priority -> Log -> IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Debug Log
LogServerShutdownMessage
    -- stop the reactor to free up the hiedb connection
    IO () -> ServerM c ()
forall a. IO a -> ServerM c a
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 () -> ServerM c ()
forall a. IO a -> ServerM c a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ServerM c ()) -> IO () -> ServerM c ()
forall a b. (a -> b) -> a -> b
$ IdeState -> IO ()
shakeShut IdeState
ide
    Either (TResponseError 'Method_Shutdown) Null -> ServerM c ()
resp (Either (TResponseError 'Method_Shutdown) Null -> ServerM c ())
-> Either (TResponseError 'Method_Shutdown) Null -> ServerM c ()
forall a b. (a -> b) -> a -> b
$ Null -> Either (TResponseError 'Method_Shutdown) Null
forall a b. b -> Either a b
Right Null
Null

exitHandler :: IO () -> LSP.Handlers (ServerM c)
exitHandler :: forall c. IO () -> Handlers (ServerM c)
exitHandler IO ()
exit = SMethod 'Method_Exit
-> Handler (ServerM c) 'Method_Exit -> Handlers (ServerM c)
forall (m :: Method 'ClientToServer 'Notification) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
LSP.notificationHandler SMethod 'Method_Exit
SMethod_Exit (Handler (ServerM c) 'Method_Exit -> Handlers (ServerM c))
-> Handler (ServerM c) 'Method_Exit -> Handlers (ServerM c)
forall a b. (a -> b) -> a -> b
$ ServerM c () -> TNotificationMessage 'Method_Exit -> ServerM c ()
forall a b. a -> b -> a
const (ServerM c () -> TNotificationMessage 'Method_Exit -> ServerM c ())
-> ServerM c ()
-> TNotificationMessage 'Method_Exit
-> ServerM c ()
forall a b. (a -> b) -> a -> b
$ IO () -> ServerM c ()
forall a. IO a -> ServerM c a
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{ LSP.optTextDocumentSync   = Just $ tweakTDS origTDS
                   }
    where
        tweakTDS :: TextDocumentSyncOptions -> TextDocumentSyncOptions
tweakTDS TextDocumentSyncOptions
tds = TextDocumentSyncOptions
tds{_openClose=Just True, _change=Just TextDocumentSyncKind_Incremental, _save=Just $ InR $ SaveOptions 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.optTextDocumentSync 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