{-# LANGUAGE ExistentialQuantification #-}
module Development.IDE.LSP.LanguageServer
( runLanguageServer
) where
import Language.Haskell.LSP.Types
import Language.Haskell.LSP.Types.Capabilities
import Development.IDE.LSP.Server
import qualified Development.IDE.GHC.Util as Ghcide
import qualified Language.Haskell.LSP.Control as LSP
import qualified Language.Haskell.LSP.Core as LSP
import Control.Concurrent.Chan
import Control.Concurrent.Extra
import Control.Concurrent.Async
import Control.Concurrent.STM
import Control.Exception.Safe
import Data.Default
import Data.Maybe
import qualified Data.Set as Set
import qualified Data.Text as T
import GHC.IO.Handle (hDuplicate)
import System.IO
import Control.Monad.Extra
import Development.IDE.LSP.HoverDefinition
import Development.IDE.LSP.CodeAction
import Development.IDE.LSP.Completions
import Development.IDE.LSP.Notifications
import Development.IDE.LSP.Outline
import Development.IDE.Core.Service
import Development.IDE.Types.Logger
import Development.IDE.Core.FileStore
import Language.Haskell.LSP.Core (LspFuncs(..))
import Language.Haskell.LSP.Messages
runLanguageServer
:: LSP.Options
-> PartialHandlers
-> (IO LspId -> (FromServerMessage -> IO ()) -> VFSHandle -> ClientCapabilities -> IO IdeState)
-> IO ()
runLanguageServer options userHandlers getIdeState = do
newStdout <- hDuplicate stdout
stderr `Ghcide.hDuplicateTo'` stdout
hSetBuffering stderr NoBuffering
hSetBuffering stdout NoBuffering
putStr " " >> hFlush stdout
clientMsgChan :: Chan Message <- newChan
clientMsgBarrier <- newBarrier
pendingRequests <- newTVarIO Set.empty
cancelledRequests <- newTVarIO Set.empty
let withResponse wrap f = Just $ \r@RequestMessage{_id} -> do
atomically $ modifyTVar pendingRequests (Set.insert _id)
writeChan clientMsgChan $ Response r wrap f
let withNotification old f = Just $ \r -> writeChan clientMsgChan $ Notification r (\lsp ide x -> f lsp ide x >> whenJust old ($ r))
let withResponseAndRequest wrap wrapNewReq f = Just $ \r@RequestMessage{_id} -> do
atomically $ modifyTVar pendingRequests (Set.insert _id)
writeChan clientMsgChan $ ResponseAndRequest r wrap wrapNewReq f
let cancelRequest reqId = atomically $ do
queued <- readTVar pendingRequests
when (reqId `elem` queued) $
modifyTVar cancelledRequests (Set.insert reqId)
let clearReqId reqId = atomically $ do
modifyTVar pendingRequests (Set.delete reqId)
modifyTVar cancelledRequests (Set.delete reqId)
let waitForCancel reqId = atomically $ do
cancelled <- readTVar cancelledRequests
unless (reqId `Set.member` cancelled) retry
let PartialHandlers parts =
setHandlersIgnore <>
setHandlersDefinition <> setHandlersHover <>
setHandlersCodeAction <> setHandlersCodeLens <>
setHandlersCompletion <>
setHandlersOutline <>
userHandlers <>
setHandlersNotifications <>
cancelHandler cancelRequest
handlers <- parts WithMessage{withResponse, withNotification, withResponseAndRequest} def
let initializeCallbacks = LSP.InitializeCallbacks
{ LSP.onInitialConfiguration = const $ Right ()
, LSP.onConfigurationChange = const $ Right ()
, LSP.onStartup = handleInit (signalBarrier clientMsgBarrier ()) clearReqId waitForCancel clientMsgChan
}
void $ waitAnyCancel =<< traverse async
[ void $ LSP.runWithHandles
stdin
newStdout
initializeCallbacks
handlers
(modifyOptions options)
Nothing
, void $ waitBarrier clientMsgBarrier
]
where
handleInit :: IO () -> (LspId -> IO ()) -> (LspId -> IO ()) -> Chan Message -> LSP.LspFuncs () -> IO (Maybe err)
handleInit exitClientMsg clearReqId waitForCancel clientMsgChan lspFuncs@LSP.LspFuncs{..} = do
ide <- getIdeState getNextReqId sendFunc (makeLSPVFSHandle lspFuncs) clientCapabilities
_ <- flip forkFinally (const exitClientMsg) $ forever $ do
msg <- readChan clientMsgChan
case msg of
Notification x@NotificationMessage{_params} act -> do
catch (act lspFuncs ide _params) $ \(e :: SomeException) ->
logError (ideLogger ide) $ T.pack $
"Unexpected exception on notification, please report!\n" ++
"Message: " ++ show x ++ "\n" ++
"Exception: " ++ show e
Response x@RequestMessage{_id, _params} wrap act ->
checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $
\res -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Just res) Nothing
ResponseAndRequest x@RequestMessage{_id, _params} wrap wrapNewReq act ->
checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $
\(res, newReq) -> do
sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Just res) Nothing
case newReq of
Nothing -> return ()
Just (rm, newReqParams) -> do
reqId <- getNextReqId
sendFunc $ wrapNewReq $ RequestMessage "2.0" reqId rm newReqParams
pure Nothing
checkCancelled ide clearReqId waitForCancel lspFuncs@LSP.LspFuncs{..} wrap act msg _id _params k =
flip finally (clearReqId _id) $
catch (do
cancelOrRes <- race (waitForCancel _id) $ act lspFuncs ide _params
case cancelOrRes of
Left () -> do
logDebug (ideLogger ide) $ T.pack $
"Cancelled request " <> show _id
sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) Nothing $
Just $ ResponseError RequestCancelled "" Nothing
Right res -> k res
) $ \(e :: SomeException) -> do
logError (ideLogger ide) $ T.pack $
"Unexpected exception on request, please report!\n" ++
"Message: " ++ show msg ++ "\n" ++
"Exception: " ++ show e
sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) Nothing $
Just $ ResponseError InternalError (T.pack $ show e) Nothing
setHandlersIgnore :: PartialHandlers
setHandlersIgnore = PartialHandlers $ \_ x -> return x
{LSP.initializedHandler = none
,LSP.responseHandler = none
}
where none = Just $ const $ return ()
cancelHandler :: (LspId -> IO ()) -> PartialHandlers
cancelHandler cancelRequest = PartialHandlers $ \_ x -> return x
{LSP.cancelNotificationHandler = Just $ \msg@NotificationMessage {_params = CancelParams {_id}} -> do
cancelRequest _id
whenJust (LSP.cancelNotificationHandler x) ($ msg)
}
data Message
= forall m req resp . (Show m, Show req) => Response (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (LSP.LspFuncs () -> IdeState -> req -> IO resp)
| forall m rm req resp newReqParams newReqBody . (Show m, Show rm, Show req) => ResponseAndRequest (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (RequestMessage rm newReqParams newReqBody -> FromServerMessage) (LSP.LspFuncs () -> IdeState -> req -> IO (resp, Maybe (rm, newReqParams)))
| forall m req . (Show m, Show req) => Notification (NotificationMessage m req) (LSP.LspFuncs () -> IdeState -> req -> IO ())
modifyOptions :: LSP.Options -> LSP.Options
modifyOptions x = x{ LSP.textDocumentSync = Just $ tweakTDS origTDS
, LSP.executeCommandCommands = Just ["typesignature.add"]
, LSP.completionTriggerCharacters = Just "."
}
where
tweakTDS tds = tds{_openClose=Just True, _change=Just TdSyncIncremental, _save=Just $ SaveOptions Nothing}
origTDS = fromMaybe tdsDefault $ LSP.textDocumentSync x
tdsDefault = TextDocumentSyncOptions Nothing Nothing Nothing Nothing Nothing