{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE StarIsType #-}
module Development.IDE.LSP.LanguageServer
( runLanguageServer
, setupLSP
, 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 qualified Colog.Core as Colog
import Control.Monad.IO.Unlift (MonadUnliftIO)
import Development.IDE.Core.IdeConfiguration
import Development.IDE.Core.Shake hiding (Log, Priority)
import Development.IDE.Core.Tracing
import qualified Development.IDE.Session as Session
import Development.IDE.Types.Logger
import qualified Development.IDE.Types.Logger as Logger
import Development.IDE.Types.Shake (WithHieDb)
import Language.LSP.Server (LanguageContextEnv,
LspServerLog,
type (<~>))
import System.IO.Unsafe (unsafeInterleaveIO)
data Log
= LogRegisteringIdeConfig !IdeConfiguration
| LogReactorThreadException !SomeException
| LogReactorMessageActionException !SomeException
| LogReactorThreadStopped
| LogCancelledRequest !SomeLspId
| LogSession Session.Log
| LogLspServer LspServerLog
deriving Int -> Log -> ShowS
[Log] -> ShowS
Log -> String
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 :: forall ann. Log -> Doc ann
pretty = \case
LogRegisteringIdeConfig IdeConfiguration
ideConfig ->
Doc ann
"Registering IDE configuration:" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Show a => a -> Doc ann
viaShow IdeConfiguration
ideConfig
LogReactorThreadException SomeException
e ->
forall ann. [Doc ann] -> Doc ann
vcat
[ Doc ann
"ReactorThreadException"
, forall a ann. Pretty a => a -> Doc ann
pretty forall a b. (a -> b) -> a -> b
$ forall e. Exception e => e -> String
displayException SomeException
e ]
LogReactorMessageActionException SomeException
e ->
forall ann. [Doc ann] -> Doc ann
vcat
[ Doc ann
"ReactorMessageActionException"
, forall a ann. Pretty a => a -> Doc ann
pretty forall a b. (a -> b) -> a -> b
$ forall e. Exception e => e -> String
displayException SomeException
e ]
Log
LogReactorThreadStopped ->
Doc ann
"Reactor thread stopped"
LogCancelledRequest SomeLspId
requestId ->
Doc ann
"Cancelled request" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Show a => a -> Doc ann
viaShow SomeLspId
requestId
LogSession Log
log -> forall a ann. Pretty a => a -> Doc ann
pretty Log
log
LogLspServer LspServerLog
log -> forall a ann. Pretty a => a -> Doc ann
pretty LspServerLog
log
newtype WithHieDbShield = WithHieDbShield WithHieDb
runLanguageServer
:: forall config a m. (Show config)
=> Recorder (WithPriority Log)
-> LSP.Options
-> Handle
-> Handle
-> config
-> (config -> Value -> Either T.Text config)
-> (MVar ()
-> IO (LSP.LanguageContextEnv config -> RequestMessage Initialize -> IO (Either ResponseError (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)
-> (MVar ()
-> IO
(LanguageContextEnv config
-> RequestMessage 'Initialize
-> IO (Either ResponseError (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
onConfigurationChange MVar ()
-> IO
(LanguageContextEnv config
-> RequestMessage 'Initialize
-> IO (Either ResponseError (LanguageContextEnv config, a)),
Handlers (m config),
(LanguageContextEnv config, a) -> m config <~> IO)
setup = do
MVar ()
clientMsgVar <- forall (m :: * -> *) a. MonadIO m => m (MVar a)
newEmptyMVar
(LanguageContextEnv config
-> RequestMessage 'Initialize
-> IO (Either ResponseError (LanguageContextEnv config, a))
doInitialize, Handlers (m config)
staticHandlers, (LanguageContextEnv config, a) -> m config <~> IO
interpretHandler) <- MVar ()
-> IO
(LanguageContextEnv config
-> RequestMessage 'Initialize
-> IO (Either ResponseError (LanguageContextEnv config, a)),
Handlers (m config),
(LanguageContextEnv config, a) -> m config <~> IO)
setup MVar ()
clientMsgVar
let serverDefinition :: ServerDefinition config
serverDefinition = 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, a))
LSP.doInitialize = LanguageContextEnv config
-> RequestMessage 'Initialize
-> IO (Either ResponseError (LanguageContextEnv config, a))
doInitialize
, staticHandlers :: Handlers (m config)
LSP.staticHandlers = 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 = forall (m :: * -> *) msg.
(MonadIO m, HasCallStack) =>
Recorder (WithPriority msg) -> LogAction m (WithSeverity msg)
toCologActionWithPrio forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> Recorder a -> Recorder a
cfilter
(\WithPriority LspServerLog
msg -> forall a. WithPriority a -> Priority
priority WithPriority LspServerLog
msg forall a. Ord a => a -> a -> Bool
>= Priority
Info)
(forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio LspServerLog -> Log
LogLspServer Recorder (WithPriority Log)
recorder)
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadUnliftIO m => MVar () -> m () -> m ()
untilMVar MVar ()
clientMsgVar forall a b. (a -> b) -> a -> b
$
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall config.
LogAction IO (WithSeverity LspServerLog)
-> LogAction (LspM config) (WithSeverity LspServerLog)
-> Handle
-> Handle
-> ServerDefinition config
-> IO Int
LSP.runServerWithHandles
forall (m2 :: * -> *).
MonadIO m2 =>
LogAction m2 (WithSeverity LspServerLog)
lspCologAction
forall (m2 :: * -> *).
MonadIO m2 =>
LogAction m2 (WithSeverity LspServerLog)
lspCologAction
Handle
inH
Handle
outH
ServerDefinition config
serverDefinition
setupLSP ::
forall config err.
Recorder (WithPriority Log)
-> (FilePath -> IO FilePath)
-> LSP.Handlers (ServerM config)
-> (LSP.LanguageContextEnv config -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState)
-> MVar ()
-> IO (LSP.LanguageContextEnv config -> RequestMessage 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 -> IO String)
-> Handlers (ServerM config)
-> (LanguageContextEnv config
-> Maybe String -> WithHieDb -> IndexQueue -> IO IdeState)
-> MVar ()
-> IO
(LanguageContextEnv config
-> RequestMessage 'Initialize
-> IO (Either err (LanguageContextEnv config, IdeState)),
Handlers (ServerM config),
(LanguageContextEnv config, IdeState) -> ServerM config <~> IO)
setupLSP Recorder (WithPriority Log)
recorder String -> IO String
getHieDbLoc Handlers (ServerM config)
userHandlers LanguageContextEnv config
-> Maybe String -> WithHieDb -> IndexQueue -> IO IdeState
getIdeState MVar ()
clientMsgVar = do
Chan ReactorMessage
clientMsgChan :: Chan ReactorMessage <- forall (m :: * -> *) a. MonadIO m => m (Chan a)
newChan
MVar ()
reactorLifetime <- forall (m :: * -> *) a. MonadIO m => m (MVar a)
newEmptyMVar
let stopReactorLoop :: IO ()
stopReactorLoop = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => MVar a -> a -> m Bool
tryPutMVar MVar ()
reactorLifetime ()
let exit :: IO ()
exit = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => MVar a -> a -> m Bool
tryPutMVar MVar ()
clientMsgVar ()
TVar (Set SomeLspId)
pendingRequests <- forall a. a -> IO (TVar a)
newTVarIO forall a. Set a
Set.empty
TVar (Set SomeLspId)
cancelledRequests <- forall a. a -> IO (TVar a)
newTVarIO forall a. Set a
Set.empty
let cancelRequest :: SomeLspId -> IO ()
cancelRequest SomeLspId
reqId = forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
Set SomeLspId
queued <- forall a. TVar a -> STM a
readTVar TVar (Set SomeLspId)
pendingRequests
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SomeLspId
reqId forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Set SomeLspId
queued) forall a b. (a -> b) -> a -> b
$
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Set SomeLspId)
cancelledRequests (forall a. Ord a => a -> Set a -> Set a
Set.insert SomeLspId
reqId)
let clearReqId :: SomeLspId -> IO ()
clearReqId SomeLspId
reqId = forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Set SomeLspId)
pendingRequests (forall a. Ord a => a -> Set a -> Set a
Set.delete SomeLspId
reqId)
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Set SomeLspId)
cancelledRequests (forall a. Ord a => a -> Set a -> Set a
Set.delete SomeLspId
reqId)
let waitForCancel :: SomeLspId -> IO ()
waitForCancel SomeLspId
reqId = forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
Set SomeLspId
cancelled <- forall a. TVar a -> STM a
readTVar TVar (Set SomeLspId)
cancelledRequests
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (SomeLspId
reqId forall a. Ord a => a -> Set a -> Bool
`Set.member` Set SomeLspId
cancelled) forall a. STM a
retry
let asyncHandlers :: Handlers (ServerM config)
asyncHandlers = forall a. Monoid a => [a] -> a
mconcat
[ Handlers (ServerM config)
userHandlers
, forall c. (SomeLspId -> IO ()) -> Handlers (ServerM c)
cancelHandler SomeLspId -> IO ()
cancelRequest
, forall c. IO () -> Handlers (ServerM c)
exitHandler IO ()
exit
, forall c. IO () -> Handlers (ServerM c)
shutdownHandler IO ()
stopReactorLoop
]
let doInitialize :: LanguageContextEnv config
-> RequestMessage 'Initialize
-> IO (Either err (LanguageContextEnv config, IdeState))
doInitialize = forall config err.
Recorder (WithPriority Log)
-> (String -> IO String)
-> (LanguageContextEnv config
-> Maybe String -> WithHieDb -> IndexQueue -> IO IdeState)
-> MVar ()
-> IO ()
-> (SomeLspId -> IO ())
-> (SomeLspId -> IO ())
-> Chan ReactorMessage
-> LanguageContextEnv config
-> RequestMessage 'Initialize
-> IO (Either err (LanguageContextEnv config, IdeState))
handleInit Recorder (WithPriority Log)
recorder String -> IO String
getHieDbLoc LanguageContextEnv config
-> Maybe String -> WithHieDb -> IndexQueue -> 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 {k} (m :: k -> *) (n :: k -> *).
(forall (a :: k). m a -> n a)
-> (forall (a :: k). n a -> m a) -> m <~> n
LSP.Iso (forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
LSP.runLspT LanguageContextEnv config
env forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c a.
ServerM c a -> ReaderT (Chan ReactorMessage, IdeState) (LspM c) a
unServerM) (Chan ReactorMessage
clientMsgChan,IdeState
st)) forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LanguageContextEnv config
-> RequestMessage 'Initialize
-> IO (Either err (LanguageContextEnv config, IdeState))
doInitialize, Handlers (ServerM config)
asyncHandlers, (LanguageContextEnv config, IdeState) -> ServerM config <~> IO
interpretHandler)
handleInit
:: Recorder (WithPriority Log)
-> (FilePath -> IO FilePath)
-> (LSP.LanguageContextEnv config -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState)
-> MVar ()
-> IO ()
-> (SomeLspId -> IO ())
-> (SomeLspId -> IO ())
-> Chan ReactorMessage
-> LSP.LanguageContextEnv config -> RequestMessage Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState))
handleInit :: forall config err.
Recorder (WithPriority Log)
-> (String -> IO String)
-> (LanguageContextEnv config
-> Maybe String -> WithHieDb -> IndexQueue -> IO IdeState)
-> MVar ()
-> IO ()
-> (SomeLspId -> IO ())
-> (SomeLspId -> IO ())
-> Chan ReactorMessage
-> LanguageContextEnv config
-> RequestMessage 'Initialize
-> IO (Either err (LanguageContextEnv config, IdeState))
handleInit Recorder (WithPriority Log)
recorder String -> IO String
getHieDbLoc LanguageContextEnv config
-> Maybe String -> WithHieDb -> IndexQueue -> IO IdeState
getIdeState 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) = forall (m :: * -> *) a.
MonadUnliftIO m =>
String -> String -> (SpanInFlight -> m a) -> m a
otTracedHandler String
"Initialize" (forall a. Show a => a -> String
show SMethod 'Initialize
m) forall a b. (a -> b) -> a -> b
$ \SpanInFlight
sp -> do
forall a. HasTracing a => SpanInFlight -> a -> IO ()
traceWithSpan SpanInFlight
sp MessageParams 'Initialize
params
let root :: Maybe String
root = forall config. LanguageContextEnv config -> Maybe String
LSP.resRootPath LanguageContextEnv config
env
String
dir <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall (m :: * -> *). MonadIO m => m String
getCurrentDirectory forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
root
String
dbLoc <- String -> IO String
getHieDbLoc String
dir
MVar (WithHieDbShield, IndexQueue)
dbMVar <- forall (m :: * -> *) a. MonadIO m => m (MVar a)
newEmptyMVar
~(WithHieDbShield WithHieDb
withHieDb,IndexQueue
hieChan) <- forall a. IO a -> IO a
unsafeInterleaveIO forall a b. (a -> b) -> a -> b
$ 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
params
Priority -> Log -> IO ()
log Priority
Info 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 forall a b. (a -> b) -> a -> b
$ SomeException -> Log
LogReactorThreadException SomeException
e
IO ()
exitClientMsg
handleServerException (Right ()
_) = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
exceptionInHandler :: SomeException -> IO ()
exceptionInHandler SomeException
e = do
Priority -> Log -> IO ()
log Priority
Error 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 =
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
finally (SomeLspId -> IO ()
clearReqId SomeLspId
_id) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
catch (do
Either () ()
cancelOrRes <- 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 forall a b. (a -> b) -> a -> b
$ SomeLspId -> Log
LogCancelledRequest SomeLspId
_id
ResponseError -> IO ()
k forall a b. (a -> b) -> a -> b
$ ErrorCode -> Text -> Maybe Value -> ResponseError
ResponseError ErrorCode
RequestCancelled Text
"" forall a. Maybe a
Nothing
Right ()
res -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
res
) forall a b. (a -> b) -> a -> b
$ \(SomeException
e :: SomeException) -> do
SomeException -> IO ()
exceptionInHandler SomeException
e
ResponseError -> IO ()
k forall a b. (a -> b) -> a -> b
$ ErrorCode -> Text -> Maybe Value -> ResponseError
ResponseError ErrorCode
InternalError (String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show SomeException
e) forall a. Maybe a
Nothing
ThreadId
_ <- forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (Either SomeException a -> m ()) -> m ThreadId
forkFinally Either SomeException () -> IO ()
handleServerException forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *). MonadUnliftIO m => MVar () -> m () -> m ()
untilMVar MVar ()
lifetime forall a b. (a -> b) -> a -> b
$ Recorder (WithPriority Log)
-> String -> (WithHieDb -> IndexQueue -> IO ()) -> IO ()
runWithDb (forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogSession Recorder (WithPriority Log)
recorder) String
dbLoc forall a b. (a -> b) -> a -> b
$ \WithHieDb
withHieDb IndexQueue
hieChan -> do
forall (m :: * -> *) a. MonadIO m => MVar a -> a -> m ()
putMVar MVar (WithHieDbShield, IndexQueue)
dbMVar (WithHieDb -> WithHieDbShield
WithHieDbShield WithHieDb
withHieDb,IndexQueue
hieChan)
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ do
ReactorMessage
msg <- forall (m :: * -> *) a. MonadIO m => Chan a -> m a
readChan Chan ReactorMessage
clientMsgChan
case ReactorMessage
msg of
ReactorNotification IO ()
act -> 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 -> forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
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
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right (LanguageContextEnv config
env,IdeState
ide)
where
log :: Logger.Priority -> Log -> IO ()
log :: Priority -> Log -> IO ()
log = forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder
untilMVar :: MonadUnliftIO m => MVar () -> m () -> m ()
untilMVar :: forall (m :: * -> *). MonadUnliftIO m => MVar () -> m () -> m ()
untilMVar MVar ()
mvar m ()
io = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. MonadIO m => [Async a] -> m (Async a, a)
waitAnyCancel forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async [ m ()
io , 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 = forall (m :: Method 'FromClient 'Notification) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
LSP.notificationHandler forall {f :: From}. SMethod 'CancelRequest
SCancelRequest forall a b. (a -> b) -> a -> b
$ \NotificationMessage{$sel:_params:NotificationMessage :: forall (f :: From) (m :: Method f 'Notification).
NotificationMessage m -> MessageParams m
_params=CancelParams{LspId m
$sel:_id:CancelParams :: ()
_id :: LspId m
_id}} ->
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ SomeLspId -> IO ()
cancelRequest (forall {f :: From} (m :: Method f 'Request). LspId m -> SomeLspId
SomeLspId LspId m
_id)
shutdownHandler :: IO () -> LSP.Handlers (ServerM c)
shutdownHandler :: forall c. IO () -> Handlers (ServerM c)
shutdownHandler IO ()
stopReactor = forall (m :: Method 'FromClient 'Request) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
LSP.requestHandler SMethod 'Shutdown
SShutdown forall a b. (a -> b) -> a -> b
$ \RequestMessage 'Shutdown
_ Either ResponseError Empty -> ServerM c ()
resp -> do
(Chan ReactorMessage
_, IdeState
ide) <- forall r (m :: * -> *). MonadReader r m => m r
ask
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> Text -> IO ()
logDebug (IdeState -> Logger
ideLogger IdeState
ide) Text
"Received shutdown message"
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
stopReactor
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ IdeState -> IO ()
shakeShut IdeState
ide
Either ResponseError Empty -> ServerM c ()
resp forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right Empty
Empty
exitHandler :: IO () -> LSP.Handlers (ServerM c)
exitHandler :: forall c. IO () -> Handlers (ServerM c)
exitHandler IO ()
exit = forall (m :: Method 'FromClient 'Notification) (f :: * -> *).
SMethod m -> Handler f m -> Handlers f
LSP.notificationHandler SMethod 'Exit
SExit forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ 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 = forall a. a -> Maybe a
Just 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=forall a. a -> Maybe a
Just Bool
True, $sel:_change:TextDocumentSyncOptions :: Maybe TextDocumentSyncKind
_change=forall a. a -> Maybe a
Just TextDocumentSyncKind
TdSyncIncremental, $sel:_save:TextDocumentSyncOptions :: Maybe (Bool |? SaveOptions)
_save=forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. b -> a |? b
InR forall a b. (a -> b) -> a -> b
$ Maybe Bool -> SaveOptions
SaveOptions forall a. Maybe a
Nothing}
origTDS :: TextDocumentSyncOptions
origTDS = forall a. a -> Maybe a -> a
fromMaybe TextDocumentSyncOptions
tdsDefault 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 forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing