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

-- SPDX-License-Identifier: Apache-2.0


{-# LANGUAGE ExistentialQuantification  #-}
{-# LANGUAGE RankNTypes                 #-}

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

-- This version removes the daml: handling

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

import           Language.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.Core.IdeConfiguration
import Development.IDE.Core.Shake
import Development.IDE.LSP.HoverDefinition
import Development.IDE.LSP.Notifications
import Development.IDE.LSP.Outline
import Development.IDE.Types.Logger
import Development.IDE.Core.FileStore
import Development.IDE.Core.Tracing
import Language.Haskell.LSP.Core (LspFuncs(..))
import Language.Haskell.LSP.Messages

runLanguageServer
    :: forall config. (Show config)
    => LSP.Options
    -> PartialHandlers config
    -> (InitializeRequest -> Either T.Text config)
    -> (DidChangeConfigurationNotification -> Either T.Text config)
    -> (IO LspId -> (FromServerMessage -> IO ()) -> VFSHandle -> ClientCapabilities
        -> WithProgressFunc -> WithIndefiniteProgressFunc -> IO (Maybe config) -> Maybe FilePath -> IO IdeState)
    -> IO ()
runLanguageServer :: Options
-> PartialHandlers config
-> (InitializeRequest -> Either Text config)
-> (DidChangeConfigurationNotification -> Either Text config)
-> (IO LspId
    -> (FromServerMessage -> IO ())
    -> VFSHandle
    -> ClientCapabilities
    -> WithProgressFunc
    -> WithIndefiniteProgressFunc
    -> IO (Maybe config)
    -> Maybe FilePath
    -> IO IdeState)
-> IO ()
runLanguageServer Options
options PartialHandlers config
userHandlers InitializeRequest -> Either Text config
onInitialConfig DidChangeConfigurationNotification -> Either Text config
onConfigChange IO LspId
-> (FromServerMessage -> IO ())
-> VFSHandle
-> ClientCapabilities
-> WithProgressFunc
-> WithIndefiniteProgressFunc
-> IO (Maybe config)
-> Maybe FilePath
-> IO IdeState
getIdeState = do
    -- Move stdout to another file descriptor and duplicate stderr

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

    -- message stream.

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

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

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

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

    -- the language server tests without the redirection.

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

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

    -- LspFuncs is available

    Chan (Message config)
clientMsgChan :: Chan (Message config) <- IO (Chan (Message config))
forall a. IO (Chan a)
newChan

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

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

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

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

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

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

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

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

    let withResponse :: (ResponseMessage resp -> FromServerMessage)
-> (LspFuncs config
    -> IdeState -> req -> IO (Either ResponseError resp))
-> Maybe (RequestMessage m req resp -> IO ())
withResponse ResponseMessage resp -> FromServerMessage
wrap LspFuncs config
-> IdeState -> req -> IO (Either ResponseError resp)
f = (RequestMessage m req resp -> IO ())
-> Maybe (RequestMessage m req resp -> IO ())
forall a. a -> Maybe a
Just ((RequestMessage m req resp -> IO ())
 -> Maybe (RequestMessage m req resp -> IO ()))
-> (RequestMessage m req resp -> IO ())
-> Maybe (RequestMessage m req resp -> IO ())
forall a b. (a -> b) -> a -> b
$ \r :: RequestMessage m req resp
r@RequestMessage{LspId
$sel:_id:RequestMessage :: forall m req resp. RequestMessage m req resp -> LspId
_id :: LspId
_id, m
$sel:_method:RequestMessage :: forall m req resp. RequestMessage m req resp -> m
_method :: m
_method} -> do
            STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (Set LspId) -> (Set LspId -> Set LspId) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Set LspId)
pendingRequests (LspId -> Set LspId -> Set LspId
forall a. Ord a => a -> Set a -> Set a
Set.insert LspId
_id)
            Chan (Message config) -> Message config -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan (Message config)
clientMsgChan (Message config -> IO ()) -> Message config -> IO ()
forall a b. (a -> b) -> a -> b
$ RequestMessage m req resp
-> (ResponseMessage resp -> FromServerMessage)
-> (LspFuncs config
    -> IdeState -> req -> IO (Either ResponseError resp))
-> Message config
forall c m req resp.
(Show m, Show req, HasTracing req) =>
RequestMessage m req resp
-> (ResponseMessage resp -> FromServerMessage)
-> (LspFuncs c
    -> IdeState -> req -> IO (Either ResponseError resp))
-> Message c
Response RequestMessage m req resp
r ResponseMessage resp -> FromServerMessage
wrap LspFuncs config
-> IdeState -> req -> IO (Either ResponseError resp)
f
    let withNotification :: Maybe (NotificationMessage m t -> IO ())
-> (LspFuncs config -> IdeState -> t -> IO a)
-> Maybe (NotificationMessage m t -> IO ())
withNotification Maybe (NotificationMessage m t -> IO ())
old LspFuncs config -> IdeState -> t -> IO a
f = (NotificationMessage m t -> IO ())
-> Maybe (NotificationMessage m t -> IO ())
forall a. a -> Maybe a
Just ((NotificationMessage m t -> IO ())
 -> Maybe (NotificationMessage m t -> IO ()))
-> (NotificationMessage m t -> IO ())
-> Maybe (NotificationMessage m t -> IO ())
forall a b. (a -> b) -> a -> b
$ \r :: NotificationMessage m t
r@NotificationMessage{m
$sel:_method:NotificationMessage :: forall m a. NotificationMessage m a -> m
_method :: m
_method} ->
            Chan (Message config) -> Message config -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan (Message config)
clientMsgChan (Message config -> IO ()) -> Message config -> IO ()
forall a b. (a -> b) -> a -> b
$ NotificationMessage m t
-> (LspFuncs config -> IdeState -> t -> IO ()) -> Message config
forall c m req.
(Show m, Show req, HasTracing req) =>
NotificationMessage m req
-> (LspFuncs c -> IdeState -> req -> IO ()) -> Message c
Notification NotificationMessage m t
r (\LspFuncs config
lsp IdeState
ide t
x -> LspFuncs config -> IdeState -> t -> IO a
f LspFuncs config
lsp IdeState
ide t
x IO a -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe (NotificationMessage m t -> IO ())
-> ((NotificationMessage m t -> IO ()) -> IO ()) -> IO ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe (NotificationMessage m t -> IO ())
old ((NotificationMessage m t -> IO ())
-> NotificationMessage m t -> IO ()
forall a b. (a -> b) -> a -> b
$ NotificationMessage m t
r))
    let withResponseAndRequest :: (ResponseMessage resp -> FromServerMessage)
-> (RequestMessage rm newReqParams newReqBody -> FromServerMessage)
-> (LspFuncs config
    -> IdeState
    -> req
    -> IO (Either ResponseError resp, Maybe (rm, newReqParams)))
-> Maybe (RequestMessage m req resp -> IO ())
withResponseAndRequest ResponseMessage resp -> FromServerMessage
wrap RequestMessage rm newReqParams newReqBody -> FromServerMessage
wrapNewReq LspFuncs config
-> IdeState
-> req
-> IO (Either ResponseError resp, Maybe (rm, newReqParams))
f = (RequestMessage m req resp -> IO ())
-> Maybe (RequestMessage m req resp -> IO ())
forall a. a -> Maybe a
Just ((RequestMessage m req resp -> IO ())
 -> Maybe (RequestMessage m req resp -> IO ()))
-> (RequestMessage m req resp -> IO ())
-> Maybe (RequestMessage m req resp -> IO ())
forall a b. (a -> b) -> a -> b
$ \r :: RequestMessage m req resp
r@RequestMessage{LspId
_id :: LspId
$sel:_id:RequestMessage :: forall m req resp. RequestMessage m req resp -> LspId
_id, m
_method :: m
$sel:_method:RequestMessage :: forall m req resp. RequestMessage m req resp -> m
_method} -> do
            STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (Set LspId) -> (Set LspId -> Set LspId) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Set LspId)
pendingRequests (LspId -> Set LspId -> Set LspId
forall a. Ord a => a -> Set a -> Set a
Set.insert LspId
_id)
            Chan (Message config) -> Message config -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan (Message config)
clientMsgChan (Message config -> IO ()) -> Message config -> IO ()
forall a b. (a -> b) -> a -> b
$ RequestMessage m req resp
-> (ResponseMessage resp -> FromServerMessage)
-> (RequestMessage rm newReqParams newReqBody -> FromServerMessage)
-> (LspFuncs config
    -> IdeState
    -> req
    -> IO (Either ResponseError resp, Maybe (rm, newReqParams)))
-> Message config
forall c m rm req resp newReqParams newReqBody.
(Show m, Show rm, Show req, HasTracing req) =>
RequestMessage m req resp
-> (ResponseMessage resp -> FromServerMessage)
-> (RequestMessage rm newReqParams newReqBody -> FromServerMessage)
-> (LspFuncs c
    -> IdeState
    -> req
    -> IO (Either ResponseError resp, Maybe (rm, newReqParams)))
-> Message c
ResponseAndRequest RequestMessage m req resp
r ResponseMessage resp -> FromServerMessage
wrap RequestMessage rm newReqParams newReqBody -> FromServerMessage
wrapNewReq LspFuncs config
-> IdeState
-> req
-> IO (Either ResponseError resp, Maybe (rm, newReqParams))
f
    let withInitialize :: (LspFuncs config -> IdeState -> InitializeParams -> IO ())
-> Maybe (InitializeRequest -> IO ())
withInitialize LspFuncs config -> IdeState -> InitializeParams -> IO ()
f = (InitializeRequest -> IO ()) -> Maybe (InitializeRequest -> IO ())
forall a. a -> Maybe a
Just ((InitializeRequest -> IO ())
 -> Maybe (InitializeRequest -> IO ()))
-> (InitializeRequest -> IO ())
-> Maybe (InitializeRequest -> IO ())
forall a b. (a -> b) -> a -> b
$ \InitializeRequest
r ->
            Chan (Message config) -> Message config -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan (Message config)
clientMsgChan (Message config -> IO ()) -> Message config -> IO ()
forall a b. (a -> b) -> a -> b
$ InitializeRequest
-> (LspFuncs config -> IdeState -> InitializeParams -> IO ())
-> Message config
forall c.
InitializeRequest
-> (LspFuncs c -> IdeState -> InitializeParams -> IO ())
-> Message c
InitialParams InitializeRequest
r (\LspFuncs config
lsp IdeState
ide InitializeParams
x -> LspFuncs config -> IdeState -> InitializeParams -> IO ()
f LspFuncs config
lsp IdeState
ide InitializeParams
x)
    let cancelRequest :: LspId -> IO ()
cancelRequest LspId
reqId = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            Set LspId
queued <- TVar (Set LspId) -> STM (Set LspId)
forall a. TVar a -> STM a
readTVar TVar (Set LspId)
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 (LspId
reqId LspId -> Set LspId -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Set LspId
queued) (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$
                TVar (Set LspId) -> (Set LspId -> Set LspId) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Set LspId)
cancelledRequests (LspId -> Set LspId -> Set LspId
forall a. Ord a => a -> Set a -> Set a
Set.insert LspId
reqId)
    let clearReqId :: LspId -> IO ()
clearReqId LspId
reqId = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            TVar (Set LspId) -> (Set LspId -> Set LspId) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Set LspId)
pendingRequests (LspId -> Set LspId -> Set LspId
forall a. Ord a => a -> Set a -> Set a
Set.delete LspId
reqId)
            TVar (Set LspId) -> (Set LspId -> Set LspId) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Set LspId)
cancelledRequests (LspId -> Set LspId -> Set LspId
forall a. Ord a => a -> Set a -> Set a
Set.delete LspId
reqId)
        -- We implement request cancellation by racing waitForCancel against

        -- the actual request handler.

    let waitForCancel :: LspId -> IO ()
waitForCancel LspId
reqId = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            Set LspId
cancelled <- TVar (Set LspId) -> STM (Set LspId)
forall a. TVar a -> STM a
readTVar TVar (Set LspId)
cancelledRequests
            Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (LspId
reqId LspId -> Set LspId -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set LspId
cancelled) STM ()
forall a. STM a
retry
    let PartialHandlers WithMessage config -> Handlers -> IO Handlers
parts =
            PartialHandlers config
forall config. PartialHandlers config
initializeRequestHandler PartialHandlers config
-> PartialHandlers config -> PartialHandlers config
forall a. Semigroup a => a -> a -> a
<>
            PartialHandlers config
forall config. PartialHandlers config
setHandlersIgnore PartialHandlers config
-> PartialHandlers config -> PartialHandlers config
forall a. Semigroup a => a -> a -> a
<> -- least important

            PartialHandlers config
forall config. PartialHandlers config
setHandlersDefinition PartialHandlers config
-> PartialHandlers config -> PartialHandlers config
forall a. Semigroup a => a -> a -> a
<> PartialHandlers config
forall config. PartialHandlers config
setHandlersTypeDefinition PartialHandlers config
-> PartialHandlers config -> PartialHandlers config
forall a. Semigroup a => a -> a -> a
<>
            PartialHandlers config
forall config. PartialHandlers config
setHandlersDocHighlight PartialHandlers config
-> PartialHandlers config -> PartialHandlers config
forall a. Semigroup a => a -> a -> a
<>
            PartialHandlers config
forall config. PartialHandlers config
setHandlersOutline PartialHandlers config
-> PartialHandlers config -> PartialHandlers config
forall a. Semigroup a => a -> a -> a
<>
            PartialHandlers config
userHandlers PartialHandlers config
-> PartialHandlers config -> PartialHandlers config
forall a. Semigroup a => a -> a -> a
<>
            PartialHandlers config
forall config. PartialHandlers config
setHandlersNotifications PartialHandlers config
-> PartialHandlers config -> PartialHandlers config
forall a. Semigroup a => a -> a -> a
<> -- absolutely critical, join them with user notifications

            (LspId -> IO ()) -> PartialHandlers config
forall config. (LspId -> IO ()) -> PartialHandlers config
cancelHandler LspId -> IO ()
cancelRequest PartialHandlers config
-> PartialHandlers config -> PartialHandlers config
forall a. Semigroup a => a -> a -> a
<>
            IO () -> PartialHandlers config
forall c. IO () -> PartialHandlers c
exitHandler IO ()
exit
            -- Cancel requests are special since they need to be handled

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

    Handlers
handlers <- WithMessage config -> Handlers -> IO Handlers
parts WithMessage :: forall c.
(forall m req resp.
 (Show m, Show req, HasTracing req) =>
 (ResponseMessage resp -> FromServerMessage)
 -> (LspFuncs c
     -> IdeState -> req -> IO (Either ResponseError resp))
 -> Maybe (Handler (RequestMessage m req resp)))
-> (forall m req.
    (Show m, Show req, HasTracing req) =>
    Maybe (Handler (NotificationMessage m req))
    -> (LspFuncs c -> IdeState -> req -> IO ())
    -> Maybe (Handler (NotificationMessage m req)))
-> (forall m rm req resp newReqParams newReqBody.
    (Show m, Show rm, Show req, Show newReqParams, Show newReqBody,
     HasTracing req) =>
    (ResponseMessage resp -> FromServerMessage)
    -> (RequestMessage rm newReqParams newReqBody -> FromServerMessage)
    -> (LspFuncs c
        -> IdeState
        -> req
        -> IO (Either ResponseError resp, Maybe (rm, newReqParams)))
    -> Maybe (Handler (RequestMessage m req resp)))
-> ((LspFuncs c -> IdeState -> InitializeParams -> IO ())
    -> Maybe (InitializeRequest -> IO ()))
-> WithMessage c
WithMessage{forall m req resp.
(Show m, Show req, HasTracing req) =>
(ResponseMessage resp -> FromServerMessage)
-> (LspFuncs config
    -> IdeState -> req -> IO (Either ResponseError resp))
-> Maybe (RequestMessage m req resp -> IO ())
$sel:withResponse:WithMessage :: forall m req resp.
(Show m, Show req, HasTracing req) =>
(ResponseMessage resp -> FromServerMessage)
-> (LspFuncs config
    -> IdeState -> req -> IO (Either ResponseError resp))
-> Maybe (RequestMessage m req resp -> IO ())
withResponse :: forall m req resp.
(Show m, Show req, HasTracing req) =>
(ResponseMessage resp -> FromServerMessage)
-> (LspFuncs config
    -> IdeState -> req -> IO (Either ResponseError resp))
-> Maybe (RequestMessage m req resp -> IO ())
withResponse, forall m req.
(Show m, Show req, HasTracing req) =>
Maybe (NotificationMessage m req -> IO ())
-> (LspFuncs config -> IdeState -> req -> IO ())
-> Maybe (NotificationMessage m req -> IO ())
forall m t a.
(Show m, Show t, HasTracing t) =>
Maybe (NotificationMessage m t -> IO ())
-> (LspFuncs config -> IdeState -> t -> IO a)
-> Maybe (NotificationMessage m t -> IO ())
$sel:withNotification:WithMessage :: forall m req.
(Show m, Show req, HasTracing req) =>
Maybe (NotificationMessage m req -> IO ())
-> (LspFuncs config -> IdeState -> req -> IO ())
-> Maybe (NotificationMessage m req -> IO ())
withNotification :: forall m t a.
(Show m, Show t, HasTracing t) =>
Maybe (NotificationMessage m t -> IO ())
-> (LspFuncs config -> IdeState -> t -> IO a)
-> Maybe (NotificationMessage m t -> IO ())
withNotification, forall m rm req resp newReqParams newReqBody.
(Show m, Show rm, Show req, Show newReqParams, Show newReqBody,
 HasTracing req) =>
(ResponseMessage resp -> FromServerMessage)
-> (RequestMessage rm newReqParams newReqBody -> FromServerMessage)
-> (LspFuncs config
    -> IdeState
    -> req
    -> IO (Either ResponseError resp, Maybe (rm, newReqParams)))
-> Maybe (RequestMessage m req resp -> IO ())
forall m rm req resp newReqParams newReqBody.
(Show m, Show rm, Show req, HasTracing req) =>
(ResponseMessage resp -> FromServerMessage)
-> (RequestMessage rm newReqParams newReqBody -> FromServerMessage)
-> (LspFuncs config
    -> IdeState
    -> req
    -> IO (Either ResponseError resp, Maybe (rm, newReqParams)))
-> Maybe (RequestMessage m req resp -> IO ())
$sel:withResponseAndRequest:WithMessage :: forall m rm req resp newReqParams newReqBody.
(Show m, Show rm, Show req, Show newReqParams, Show newReqBody,
 HasTracing req) =>
(ResponseMessage resp -> FromServerMessage)
-> (RequestMessage rm newReqParams newReqBody -> FromServerMessage)
-> (LspFuncs config
    -> IdeState
    -> req
    -> IO (Either ResponseError resp, Maybe (rm, newReqParams)))
-> Maybe (RequestMessage m req resp -> IO ())
withResponseAndRequest :: forall m rm req resp newReqParams newReqBody.
(Show m, Show rm, Show req, HasTracing req) =>
(ResponseMessage resp -> FromServerMessage)
-> (RequestMessage rm newReqParams newReqBody -> FromServerMessage)
-> (LspFuncs config
    -> IdeState
    -> req
    -> IO (Either ResponseError resp, Maybe (rm, newReqParams)))
-> Maybe (RequestMessage m req resp -> IO ())
withResponseAndRequest, (LspFuncs config -> IdeState -> InitializeParams -> IO ())
-> Maybe (InitializeRequest -> IO ())
$sel:withInitialize:WithMessage :: (LspFuncs config -> IdeState -> InitializeParams -> IO ())
-> Maybe (InitializeRequest -> IO ())
withInitialize :: (LspFuncs config -> IdeState -> InitializeParams -> IO ())
-> Maybe (InitializeRequest -> IO ())
withInitialize} Handlers
forall a. Default a => a
def

    let initializeCallbacks :: InitializeCallbacks config
initializeCallbacks = InitializeCallbacks :: forall config.
(InitializeRequest -> Either Text config)
-> (DidChangeConfigurationNotification -> Either Text config)
-> (LspFuncs config -> IO (Maybe ResponseError))
-> InitializeCallbacks config
LSP.InitializeCallbacks
            { onInitialConfiguration :: InitializeRequest -> Either Text config
LSP.onInitialConfiguration = InitializeRequest -> Either Text config
onInitialConfig
            , onConfigurationChange :: DidChangeConfigurationNotification -> Either Text config
LSP.onConfigurationChange = DidChangeConfigurationNotification -> Either Text config
onConfigChange
            , onStartup :: LspFuncs config -> IO (Maybe ResponseError)
LSP.onStartup = IO ()
-> (LspId -> IO ())
-> (LspId -> IO ())
-> Chan (Message config)
-> LspFuncs config
-> IO (Maybe ResponseError)
forall err.
IO ()
-> (LspId -> IO ())
-> (LspId -> IO ())
-> Chan (Message config)
-> LspFuncs config
-> IO (Maybe err)
handleInit IO ()
exit LspId -> IO ()
clearReqId LspId -> IO ()
waitForCancel Chan (Message config)
clientMsgChan
            }

    IO (Async (), ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Async (), ()) -> IO ()) -> IO (Async (), ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ [Async ()] -> IO (Async (), ())
forall a. [Async a] -> IO (Async a, a)
waitAnyCancel ([Async ()] -> IO (Async (), ()))
-> IO [Async ()] -> IO (Async (), ())
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (IO () -> IO (Async ())) -> [IO ()] -> IO [Async ()]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async
        [ IO Int -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Int -> IO ()) -> IO Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle
-> Handle
-> InitializeCallbacks config
-> Handlers
-> Options
-> Maybe FilePath
-> IO Int
forall config.
Show config =>
Handle
-> Handle
-> InitializeCallbacks config
-> Handlers
-> Options
-> Maybe FilePath
-> IO Int
LSP.runWithHandles
            Handle
stdin
            Handle
newStdout
            InitializeCallbacks config
initializeCallbacks
            Handlers
handlers
            (Options -> Options
modifyOptions Options
options)
            Maybe FilePath
forall a. Maybe a
Nothing
        , IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Barrier () -> IO ()
forall a. Barrier a -> IO a
waitBarrier Barrier ()
clientMsgBarrier
        ]
    where
        handleInit :: IO () -> (LspId -> IO ()) -> (LspId -> IO ()) -> Chan (Message config) -> LSP.LspFuncs config -> IO (Maybe err)
        handleInit :: IO ()
-> (LspId -> IO ())
-> (LspId -> IO ())
-> Chan (Message config)
-> LspFuncs config
-> IO (Maybe err)
handleInit IO ()
exitClientMsg LspId -> IO ()
clearReqId LspId -> IO ()
waitForCancel Chan (Message config)
clientMsgChan lspFuncs :: LspFuncs config
lspFuncs@LSP.LspFuncs{Maybe FilePath
IO (Maybe config)
IO (Maybe [WorkspaceFolder])
IO LspId
IO (FilePath -> FilePath)
ClientCapabilities
FlushDiagnosticsBySourceFunc
PublishDiagnosticsFunc
FromServerMessage -> IO ()
NormalizedUri -> IO (Maybe FilePath)
NormalizedUri -> IO (Maybe VirtualFile)
WithIndefiniteProgressFunc
WithProgressFunc
clientCapabilities :: forall c. LspFuncs c -> ClientCapabilities
config :: forall c. LspFuncs c -> IO (Maybe c)
sendFunc :: forall c. LspFuncs c -> FromServerMessage -> IO ()
getVirtualFileFunc :: forall c. LspFuncs c -> NormalizedUri -> IO (Maybe VirtualFile)
persistVirtualFileFunc :: forall c. LspFuncs c -> NormalizedUri -> IO (Maybe FilePath)
reverseFileMapFunc :: forall c. LspFuncs c -> IO (FilePath -> FilePath)
publishDiagnosticsFunc :: forall c. LspFuncs c -> PublishDiagnosticsFunc
flushDiagnosticsBySourceFunc :: forall c. LspFuncs c -> FlushDiagnosticsBySourceFunc
getNextReqId :: forall c. LspFuncs c -> IO LspId
rootPath :: forall c. LspFuncs c -> Maybe FilePath
getWorkspaceFolders :: forall c. LspFuncs c -> IO (Maybe [WorkspaceFolder])
withProgress :: forall c. LspFuncs c -> WithProgressFunc
withIndefiniteProgress :: forall c. LspFuncs c -> WithIndefiniteProgressFunc
withIndefiniteProgress :: WithIndefiniteProgressFunc
withProgress :: WithProgressFunc
getWorkspaceFolders :: IO (Maybe [WorkspaceFolder])
rootPath :: Maybe FilePath
getNextReqId :: IO LspId
flushDiagnosticsBySourceFunc :: FlushDiagnosticsBySourceFunc
publishDiagnosticsFunc :: PublishDiagnosticsFunc
reverseFileMapFunc :: IO (FilePath -> FilePath)
persistVirtualFileFunc :: NormalizedUri -> IO (Maybe FilePath)
getVirtualFileFunc :: NormalizedUri -> IO (Maybe VirtualFile)
sendFunc :: FromServerMessage -> IO ()
config :: IO (Maybe config)
clientCapabilities :: ClientCapabilities
..} = do

            IdeState
ide <- IO LspId
-> (FromServerMessage -> IO ())
-> VFSHandle
-> ClientCapabilities
-> WithProgressFunc
-> WithIndefiniteProgressFunc
-> IO (Maybe config)
-> Maybe FilePath
-> IO IdeState
getIdeState IO LspId
getNextReqId FromServerMessage -> IO ()
sendFunc (LspFuncs config -> VFSHandle
forall c. LspFuncs c -> VFSHandle
makeLSPVFSHandle LspFuncs config
lspFuncs) ClientCapabilities
clientCapabilities
                               WithProgressFunc
withProgress WithIndefiniteProgressFunc
withIndefiniteProgress IO (Maybe config)
config Maybe FilePath
rootPath

            ThreadId
_ <- (IO Any -> (Either SomeException Any -> IO ()) -> IO ThreadId)
-> (Either SomeException Any -> IO ()) -> IO Any -> IO ThreadId
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO Any -> (Either SomeException Any -> IO ()) -> IO ThreadId
forall a. IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
forkFinally (IO () -> Either SomeException Any -> IO ()
forall a b. a -> b -> a
const IO ()
exitClientMsg) (IO Any -> IO ThreadId) -> IO Any -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO Any
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO Any) -> IO () -> IO Any
forall a b. (a -> b) -> a -> b
$ do
                Message config
msg <- Chan (Message config) -> IO (Message config)
forall a. Chan a -> IO a
readChan Chan (Message config)
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 Message config
msg of
                    Notification x :: NotificationMessage m req
x@NotificationMessage{req
$sel:_params:NotificationMessage :: forall m a. NotificationMessage m a -> a
_params :: req
_params, m
_method :: m
$sel:_method:NotificationMessage :: forall m a. NotificationMessage m a -> m
_method} LspFuncs config -> IdeState -> req -> IO ()
act ->
                        FilePath -> FilePath -> (SpanInFlight -> IO ()) -> IO ()
forall a. FilePath -> FilePath -> (SpanInFlight -> IO a) -> IO a
otTracedHandler FilePath
"Notification" (m -> FilePath
forall a. Show a => a -> FilePath
show m
_method) ((SpanInFlight -> IO ()) -> IO ())
-> (SpanInFlight -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \SpanInFlight
sp -> do
                          SpanInFlight -> req -> IO ()
forall a. HasTracing a => SpanInFlight -> a -> IO ()
traceWithSpan SpanInFlight
sp req
_params
                          IO () -> (SomeException -> IO ()) -> IO ()
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch (LspFuncs config -> IdeState -> req -> IO ()
act LspFuncs config
lspFuncs IdeState
ide req
_params) ((SomeException -> IO ()) -> IO ())
-> (SomeException -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(SomeException
e :: SomeException) ->
                            Logger -> Text -> IO ()
logError (IdeState -> Logger
ideLogger IdeState
ide) (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$
                                FilePath
"Unexpected exception on notification, please report!\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                                FilePath
"Message: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ NotificationMessage m req -> FilePath
forall a. Show a => a -> FilePath
show NotificationMessage m req
x FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                                FilePath
"Exception: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ SomeException -> FilePath
forall a. Show a => a -> FilePath
show SomeException
e
                    Response x :: RequestMessage m req resp
x@RequestMessage{LspId
_id :: LspId
$sel:_id:RequestMessage :: forall m req resp. RequestMessage m req resp -> LspId
_id, m
_method :: m
$sel:_method:RequestMessage :: forall m req resp. RequestMessage m req resp -> m
_method, req
$sel:_params:RequestMessage :: forall m req resp. RequestMessage m req resp -> req
_params :: req
_params} ResponseMessage resp -> FromServerMessage
wrap LspFuncs config
-> IdeState -> req -> IO (Either ResponseError resp)
act -> 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 a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$
                        FilePath -> FilePath -> (SpanInFlight -> IO ()) -> IO ()
forall a. FilePath -> FilePath -> (SpanInFlight -> IO a) -> IO a
otTracedHandler FilePath
"Request" (m -> FilePath
forall a. Show a => a -> FilePath
show m
_method) ((SpanInFlight -> IO ()) -> IO ())
-> (SpanInFlight -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \SpanInFlight
sp -> do
                          SpanInFlight -> req -> IO ()
forall a. HasTracing a => SpanInFlight -> a -> IO ()
traceWithSpan SpanInFlight
sp req
_params
                          IdeState
-> (LspId -> IO ())
-> (LspId -> IO ())
-> LspFuncs config
-> (ResponseMessage resp -> FromServerMessage)
-> (LspFuncs config
    -> IdeState -> req -> IO (Either ResponseError resp))
-> RequestMessage m req resp
-> LspId
-> req
-> (Either ResponseError resp -> IO ())
-> IO ()
forall a b c a t t.
Show a =>
IdeState
-> (LspId -> IO b)
-> (LspId -> IO ())
-> LspFuncs c
-> (ResponseMessage a -> FromServerMessage)
-> (LspFuncs c -> IdeState -> t -> IO t)
-> a
-> LspId
-> t
-> (t -> IO ())
-> IO ()
checkCancelled IdeState
ide LspId -> IO ()
clearReqId LspId -> IO ()
waitForCancel LspFuncs config
lspFuncs ResponseMessage resp -> FromServerMessage
wrap LspFuncs config
-> IdeState -> req -> IO (Either ResponseError resp)
act RequestMessage m req resp
x LspId
_id req
_params ((Either ResponseError resp -> IO ()) -> IO ())
-> (Either ResponseError resp -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
                            \case
                              Left ResponseError
e  -> FromServerMessage -> IO ()
sendFunc (FromServerMessage -> IO ()) -> FromServerMessage -> IO ()
forall a b. (a -> b) -> a -> b
$ ResponseMessage resp -> FromServerMessage
wrap (ResponseMessage resp -> FromServerMessage)
-> ResponseMessage resp -> FromServerMessage
forall a b. (a -> b) -> a -> b
$ Text
-> LspIdRsp -> Either ResponseError resp -> ResponseMessage resp
forall a.
Text -> LspIdRsp -> Either ResponseError a -> ResponseMessage a
ResponseMessage Text
"2.0" (LspId -> LspIdRsp
responseId LspId
_id) (ResponseError -> Either ResponseError resp
forall a b. a -> Either a b
Left ResponseError
e)
                              Right resp
r -> FromServerMessage -> IO ()
sendFunc (FromServerMessage -> IO ()) -> FromServerMessage -> IO ()
forall a b. (a -> b) -> a -> b
$ ResponseMessage resp -> FromServerMessage
wrap (ResponseMessage resp -> FromServerMessage)
-> ResponseMessage resp -> FromServerMessage
forall a b. (a -> b) -> a -> b
$ Text
-> LspIdRsp -> Either ResponseError resp -> ResponseMessage resp
forall a.
Text -> LspIdRsp -> Either ResponseError a -> ResponseMessage a
ResponseMessage Text
"2.0" (LspId -> LspIdRsp
responseId LspId
_id) (resp -> Either ResponseError resp
forall a b. b -> Either a b
Right resp
r)
                    ResponseAndRequest x :: RequestMessage m req resp
x@RequestMessage{LspId
_id :: LspId
$sel:_id:RequestMessage :: forall m req resp. RequestMessage m req resp -> LspId
_id, m
_method :: m
$sel:_method:RequestMessage :: forall m req resp. RequestMessage m req resp -> m
_method, req
_params :: req
$sel:_params:RequestMessage :: forall m req resp. RequestMessage m req resp -> req
_params} ResponseMessage resp -> FromServerMessage
wrap RequestMessage rm newReqParams newReqBody -> FromServerMessage
wrapNewReq LspFuncs config
-> IdeState
-> req
-> IO (Either ResponseError resp, Maybe (rm, newReqParams))
act -> 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 a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$
                        FilePath -> FilePath -> (SpanInFlight -> IO ()) -> IO ()
forall a. FilePath -> FilePath -> (SpanInFlight -> IO a) -> IO a
otTracedHandler FilePath
"Request" (m -> FilePath
forall a. Show a => a -> FilePath
show m
_method) ((SpanInFlight -> IO ()) -> IO ())
-> (SpanInFlight -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \SpanInFlight
sp -> do
                          SpanInFlight -> req -> IO ()
forall a. HasTracing a => SpanInFlight -> a -> IO ()
traceWithSpan SpanInFlight
sp req
_params
                          IdeState
-> (LspId -> IO ())
-> (LspId -> IO ())
-> LspFuncs config
-> (ResponseMessage resp -> FromServerMessage)
-> (LspFuncs config
    -> IdeState
    -> req
    -> IO (Either ResponseError resp, Maybe (rm, newReqParams)))
-> RequestMessage m req resp
-> LspId
-> req
-> ((Either ResponseError resp, Maybe (rm, newReqParams)) -> IO ())
-> IO ()
forall a b c a t t.
Show a =>
IdeState
-> (LspId -> IO b)
-> (LspId -> IO ())
-> LspFuncs c
-> (ResponseMessage a -> FromServerMessage)
-> (LspFuncs c -> IdeState -> t -> IO t)
-> a
-> LspId
-> t
-> (t -> IO ())
-> IO ()
checkCancelled IdeState
ide LspId -> IO ()
clearReqId LspId -> IO ()
waitForCancel LspFuncs config
lspFuncs ResponseMessage resp -> FromServerMessage
wrap LspFuncs config
-> IdeState
-> req
-> IO (Either ResponseError resp, Maybe (rm, newReqParams))
act RequestMessage m req resp
x LspId
_id req
_params (((Either ResponseError resp, Maybe (rm, newReqParams)) -> IO ())
 -> IO ())
-> ((Either ResponseError resp, Maybe (rm, newReqParams)) -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$
                            \(Either ResponseError resp
res, Maybe (rm, newReqParams)
newReq) -> do
                                case Either ResponseError resp
res of
                                    Left ResponseError
e  -> FromServerMessage -> IO ()
sendFunc (FromServerMessage -> IO ()) -> FromServerMessage -> IO ()
forall a b. (a -> b) -> a -> b
$ ResponseMessage resp -> FromServerMessage
wrap (ResponseMessage resp -> FromServerMessage)
-> ResponseMessage resp -> FromServerMessage
forall a b. (a -> b) -> a -> b
$ Text
-> LspIdRsp -> Either ResponseError resp -> ResponseMessage resp
forall a.
Text -> LspIdRsp -> Either ResponseError a -> ResponseMessage a
ResponseMessage Text
"2.0" (LspId -> LspIdRsp
responseId LspId
_id) (ResponseError -> Either ResponseError resp
forall a b. a -> Either a b
Left ResponseError
e)
                                    Right resp
r -> FromServerMessage -> IO ()
sendFunc (FromServerMessage -> IO ()) -> FromServerMessage -> IO ()
forall a b. (a -> b) -> a -> b
$ ResponseMessage resp -> FromServerMessage
wrap (ResponseMessage resp -> FromServerMessage)
-> ResponseMessage resp -> FromServerMessage
forall a b. (a -> b) -> a -> b
$ Text
-> LspIdRsp -> Either ResponseError resp -> ResponseMessage resp
forall a.
Text -> LspIdRsp -> Either ResponseError a -> ResponseMessage a
ResponseMessage Text
"2.0" (LspId -> LspIdRsp
responseId LspId
_id) (resp -> Either ResponseError resp
forall a b. b -> Either a b
Right resp
r)
                                Maybe (rm, newReqParams) -> ((rm, newReqParams) -> IO ()) -> IO ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe (rm, newReqParams)
newReq (((rm, newReqParams) -> IO ()) -> IO ())
-> ((rm, newReqParams) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(rm
rm, newReqParams
newReqParams) -> do
                                    LspId
reqId <- IO LspId
getNextReqId
                                    FromServerMessage -> IO ()
sendFunc (FromServerMessage -> IO ()) -> FromServerMessage -> IO ()
forall a b. (a -> b) -> a -> b
$ RequestMessage rm newReqParams newReqBody -> FromServerMessage
wrapNewReq (RequestMessage rm newReqParams newReqBody -> FromServerMessage)
-> RequestMessage rm newReqParams newReqBody -> FromServerMessage
forall a b. (a -> b) -> a -> b
$ Text
-> LspId
-> rm
-> newReqParams
-> RequestMessage rm newReqParams newReqBody
forall m req resp.
Text -> LspId -> m -> req -> RequestMessage m req resp
RequestMessage Text
"2.0" LspId
reqId rm
rm newReqParams
newReqParams
                    InitialParams x :: InitializeRequest
x@RequestMessage{LspId
_id :: LspId
$sel:_id:RequestMessage :: forall m req resp. RequestMessage m req resp -> LspId
_id, ClientMethod
_method :: ClientMethod
$sel:_method:RequestMessage :: forall m req resp. RequestMessage m req resp -> m
_method, InitializeParams
_params :: InitializeParams
$sel:_params:RequestMessage :: forall m req resp. RequestMessage m req resp -> req
_params} LspFuncs config -> IdeState -> InitializeParams -> IO ()
act ->
                        FilePath -> FilePath -> (SpanInFlight -> IO ()) -> IO ()
forall a. FilePath -> FilePath -> (SpanInFlight -> IO a) -> IO a
otTracedHandler FilePath
"Initialize" (ClientMethod -> FilePath
forall a. Show a => a -> FilePath
show ClientMethod
_method) ((SpanInFlight -> IO ()) -> IO ())
-> (SpanInFlight -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \SpanInFlight
sp -> do
                          SpanInFlight -> InitializeParams -> IO ()
forall a. HasTracing a => SpanInFlight -> a -> IO ()
traceWithSpan SpanInFlight
sp InitializeParams
_params
                          IO () -> (SomeException -> IO ()) -> IO ()
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch (LspFuncs config -> IdeState -> InitializeParams -> IO ()
act LspFuncs config
lspFuncs IdeState
ide InitializeParams
_params) ((SomeException -> IO ()) -> IO ())
-> (SomeException -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(SomeException
e :: SomeException) ->
                            Logger -> Text -> IO ()
logError (IdeState -> Logger
ideLogger IdeState
ide) (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$
                                FilePath
"Unexpected exception on InitializeRequest handler, please report!\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                                FilePath
"Message: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ InitializeRequest -> FilePath
forall a. Show a => a -> FilePath
show InitializeRequest
x FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                                FilePath
"Exception: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ SomeException -> FilePath
forall a. Show a => a -> FilePath
show SomeException
e
            Maybe err -> IO (Maybe err)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe err
forall a. Maybe a
Nothing

        checkCancelled :: IdeState
-> (LspId -> IO b)
-> (LspId -> IO ())
-> LspFuncs c
-> (ResponseMessage a -> FromServerMessage)
-> (LspFuncs c -> IdeState -> t -> IO t)
-> a
-> LspId
-> t
-> (t -> IO ())
-> IO ()
checkCancelled IdeState
ide LspId -> IO b
clearReqId LspId -> IO ()
waitForCancel lspFuncs :: LspFuncs c
lspFuncs@LSP.LspFuncs{Maybe FilePath
IO (Maybe c)
IO (Maybe [WorkspaceFolder])
IO LspId
IO (FilePath -> FilePath)
ClientCapabilities
FlushDiagnosticsBySourceFunc
PublishDiagnosticsFunc
FromServerMessage -> IO ()
NormalizedUri -> IO (Maybe FilePath)
NormalizedUri -> IO (Maybe VirtualFile)
WithIndefiniteProgressFunc
WithProgressFunc
withIndefiniteProgress :: WithIndefiniteProgressFunc
withProgress :: WithProgressFunc
getWorkspaceFolders :: IO (Maybe [WorkspaceFolder])
rootPath :: Maybe FilePath
getNextReqId :: IO LspId
flushDiagnosticsBySourceFunc :: FlushDiagnosticsBySourceFunc
publishDiagnosticsFunc :: PublishDiagnosticsFunc
reverseFileMapFunc :: IO (FilePath -> FilePath)
persistVirtualFileFunc :: NormalizedUri -> IO (Maybe FilePath)
getVirtualFileFunc :: NormalizedUri -> IO (Maybe VirtualFile)
sendFunc :: FromServerMessage -> IO ()
config :: IO (Maybe c)
clientCapabilities :: ClientCapabilities
clientCapabilities :: forall c. LspFuncs c -> ClientCapabilities
config :: forall c. LspFuncs c -> IO (Maybe c)
sendFunc :: forall c. LspFuncs c -> FromServerMessage -> IO ()
getVirtualFileFunc :: forall c. LspFuncs c -> NormalizedUri -> IO (Maybe VirtualFile)
persistVirtualFileFunc :: forall c. LspFuncs c -> NormalizedUri -> IO (Maybe FilePath)
reverseFileMapFunc :: forall c. LspFuncs c -> IO (FilePath -> FilePath)
publishDiagnosticsFunc :: forall c. LspFuncs c -> PublishDiagnosticsFunc
flushDiagnosticsBySourceFunc :: forall c. LspFuncs c -> FlushDiagnosticsBySourceFunc
getNextReqId :: forall c. LspFuncs c -> IO LspId
rootPath :: forall c. LspFuncs c -> Maybe FilePath
getWorkspaceFolders :: forall c. LspFuncs c -> IO (Maybe [WorkspaceFolder])
withProgress :: forall c. LspFuncs c -> WithProgressFunc
withIndefiniteProgress :: forall c. LspFuncs c -> WithIndefiniteProgressFunc
..} ResponseMessage a -> FromServerMessage
wrap LspFuncs c -> IdeState -> t -> IO t
act a
msg LspId
_id t
_params t -> IO ()
k =
            (IO () -> IO b -> IO ()) -> IO b -> IO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO () -> IO b -> IO ()
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
finally (LspId -> IO b
clearReqId LspId
_id) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                IO () -> (SomeException -> IO ()) -> IO ()
forall (m :: * -> *) e a.
(MonadCatch 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 () t
cancelOrRes <- IO () -> IO t -> IO (Either () t)
forall a b. IO a -> IO b -> IO (Either a b)
race (LspId -> IO ()
waitForCancel LspId
_id) (IO t -> IO (Either () t)) -> IO t -> IO (Either () t)
forall a b. (a -> b) -> a -> b
$ LspFuncs c -> IdeState -> t -> IO t
act LspFuncs c
lspFuncs IdeState
ide t
_params
                    case Either () t
cancelOrRes of
                        Left () -> do
                            Logger -> Text -> IO ()
logDebug (IdeState -> Logger
ideLogger IdeState
ide) (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$
                                FilePath
"Cancelled request " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> LspId -> FilePath
forall a. Show a => a -> FilePath
show LspId
_id
                            FromServerMessage -> IO ()
sendFunc (FromServerMessage -> IO ()) -> FromServerMessage -> IO ()
forall a b. (a -> b) -> a -> b
$ ResponseMessage a -> FromServerMessage
wrap (ResponseMessage a -> FromServerMessage)
-> ResponseMessage a -> FromServerMessage
forall a b. (a -> b) -> a -> b
$ Text -> LspIdRsp -> Either ResponseError a -> ResponseMessage a
forall a.
Text -> LspIdRsp -> Either ResponseError a -> ResponseMessage a
ResponseMessage Text
"2.0" (LspId -> LspIdRsp
responseId LspId
_id) (Either ResponseError a -> ResponseMessage a)
-> Either ResponseError a -> ResponseMessage a
forall a b. (a -> b) -> a -> b
$ ResponseError -> Either ResponseError a
forall a b. a -> Either a b
Left
                                (ResponseError -> Either ResponseError a)
-> ResponseError -> Either ResponseError a
forall a b. (a -> b) -> a -> b
$ ErrorCode -> Text -> Maybe Value -> ResponseError
ResponseError ErrorCode
RequestCancelled Text
"" Maybe Value
forall a. Maybe a
Nothing
                        Right t
res -> t -> IO ()
k t
res
                ) ((SomeException -> IO ()) -> IO ())
-> (SomeException -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(SomeException
e :: SomeException) -> do
                    Logger -> Text -> IO ()
logError (IdeState -> Logger
ideLogger IdeState
ide) (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$
                        FilePath
"Unexpected exception on request, please report!\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                        FilePath
"Message: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ a -> FilePath
forall a. Show a => a -> FilePath
show a
msg FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                        FilePath
"Exception: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ SomeException -> FilePath
forall a. Show a => a -> FilePath
show SomeException
e
                    FromServerMessage -> IO ()
sendFunc (FromServerMessage -> IO ()) -> FromServerMessage -> IO ()
forall a b. (a -> b) -> a -> b
$ ResponseMessage a -> FromServerMessage
wrap (ResponseMessage a -> FromServerMessage)
-> ResponseMessage a -> FromServerMessage
forall a b. (a -> b) -> a -> b
$ Text -> LspIdRsp -> Either ResponseError a -> ResponseMessage a
forall a.
Text -> LspIdRsp -> Either ResponseError a -> ResponseMessage a
ResponseMessage Text
"2.0" (LspId -> LspIdRsp
responseId LspId
_id) (Either ResponseError a -> ResponseMessage a)
-> Either ResponseError a -> ResponseMessage a
forall a b. (a -> b) -> a -> b
$ ResponseError -> Either ResponseError a
forall a b. a -> Either a b
Left
                        (ResponseError -> Either ResponseError a)
-> ResponseError -> Either ResponseError a
forall a b. (a -> b) -> a -> b
$ ErrorCode -> Text -> Maybe Value -> ResponseError
ResponseError ErrorCode
InternalError (FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ SomeException -> FilePath
forall a. Show a => a -> FilePath
show SomeException
e) Maybe Value
forall a. Maybe a
Nothing

initializeRequestHandler :: PartialHandlers config
initializeRequestHandler :: PartialHandlers config
initializeRequestHandler = (WithMessage config -> Handlers -> IO Handlers)
-> PartialHandlers config
forall c.
(WithMessage c -> Handlers -> IO Handlers) -> PartialHandlers c
PartialHandlers ((WithMessage config -> Handlers -> IO Handlers)
 -> PartialHandlers config)
-> (WithMessage config -> Handlers -> IO Handlers)
-> PartialHandlers config
forall a b. (a -> b) -> a -> b
$ \WithMessage{(LspFuncs config -> IdeState -> InitializeParams -> IO ())
-> Maybe (InitializeRequest -> IO ())
forall m req.
(Show m, Show req, HasTracing req) =>
Maybe (Handler (NotificationMessage m req))
-> (LspFuncs config -> IdeState -> req -> IO ())
-> Maybe (Handler (NotificationMessage m req))
forall m req resp.
(Show m, Show req, HasTracing req) =>
(ResponseMessage resp -> FromServerMessage)
-> (LspFuncs config
    -> IdeState -> req -> IO (Either ResponseError resp))
-> Maybe (Handler (RequestMessage m req resp))
forall m rm req resp newReqParams newReqBody.
(Show m, Show rm, Show req, Show newReqParams, Show newReqBody,
 HasTracing req) =>
(ResponseMessage resp -> FromServerMessage)
-> (RequestMessage rm newReqParams newReqBody -> FromServerMessage)
-> (LspFuncs config
    -> IdeState
    -> req
    -> IO (Either ResponseError resp, Maybe (rm, newReqParams)))
-> Maybe (Handler (RequestMessage m req resp))
withInitialize :: (LspFuncs config -> IdeState -> InitializeParams -> IO ())
-> Maybe (InitializeRequest -> IO ())
withResponseAndRequest :: forall m rm req resp newReqParams newReqBody.
(Show m, Show rm, Show req, Show newReqParams, Show newReqBody,
 HasTracing req) =>
(ResponseMessage resp -> FromServerMessage)
-> (RequestMessage rm newReqParams newReqBody -> FromServerMessage)
-> (LspFuncs config
    -> IdeState
    -> req
    -> IO (Either ResponseError resp, Maybe (rm, newReqParams)))
-> Maybe (Handler (RequestMessage m req resp))
withNotification :: forall m req.
(Show m, Show req, HasTracing req) =>
Maybe (Handler (NotificationMessage m req))
-> (LspFuncs config -> IdeState -> req -> IO ())
-> Maybe (Handler (NotificationMessage m req))
withResponse :: forall m req resp.
(Show m, Show req, HasTracing req) =>
(ResponseMessage resp -> FromServerMessage)
-> (LspFuncs config
    -> IdeState -> req -> IO (Either ResponseError resp))
-> Maybe (Handler (RequestMessage m req resp))
$sel:withInitialize:WithMessage :: forall c.
WithMessage c
-> (LspFuncs c -> IdeState -> InitializeParams -> IO ())
-> Maybe (InitializeRequest -> IO ())
$sel:withResponseAndRequest:WithMessage :: forall c.
WithMessage c
-> forall m rm req resp newReqParams newReqBody.
   (Show m, Show rm, Show req, Show newReqParams, Show newReqBody,
    HasTracing req) =>
   (ResponseMessage resp -> FromServerMessage)
   -> (RequestMessage rm newReqParams newReqBody -> FromServerMessage)
   -> (LspFuncs c
       -> IdeState
       -> req
       -> IO (Either ResponseError resp, Maybe (rm, newReqParams)))
   -> Maybe (Handler (RequestMessage m req resp))
$sel:withNotification:WithMessage :: forall c.
WithMessage c
-> forall m req.
   (Show m, Show req, HasTracing req) =>
   Maybe (Handler (NotificationMessage m req))
   -> (LspFuncs c -> IdeState -> req -> IO ())
   -> Maybe (Handler (NotificationMessage m req))
$sel:withResponse:WithMessage :: forall c.
WithMessage c
-> forall m req resp.
   (Show m, Show req, HasTracing req) =>
   (ResponseMessage resp -> FromServerMessage)
   -> (LspFuncs c
       -> IdeState -> req -> IO (Either ResponseError resp))
   -> Maybe (Handler (RequestMessage m req resp))
..} Handlers
x -> Handlers -> IO Handlers
forall (m :: * -> *) a. Monad m => a -> m a
return Handlers
x{
    initializeRequestHandler :: Maybe (InitializeRequest -> IO ())
LSP.initializeRequestHandler = (LspFuncs config -> IdeState -> InitializeParams -> IO ())
-> Maybe (InitializeRequest -> IO ())
withInitialize LspFuncs config -> IdeState -> InitializeParams -> IO ()
forall c. LspFuncs c -> IdeState -> InitializeParams -> IO ()
initHandler
    }

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

-- | Things that get sent to us, but we don't deal with.

--   Set them to avoid a warning in VS Code output.

setHandlersIgnore :: PartialHandlers config
setHandlersIgnore :: PartialHandlers config
setHandlersIgnore = (WithMessage config -> Handlers -> IO Handlers)
-> PartialHandlers config
forall c.
(WithMessage c -> Handlers -> IO Handlers) -> PartialHandlers c
PartialHandlers ((WithMessage config -> Handlers -> IO Handlers)
 -> PartialHandlers config)
-> (WithMessage config -> Handlers -> IO Handlers)
-> PartialHandlers config
forall a b. (a -> b) -> a -> b
$ \WithMessage config
_ Handlers
x -> Handlers -> IO Handlers
forall (m :: * -> *) a. Monad m => a -> m a
return Handlers
x
    {responseHandler :: Maybe (Handler BareResponseMessage)
LSP.responseHandler = Maybe (Handler BareResponseMessage)
forall b. Maybe (b -> IO ())
none
    }
    where none :: Maybe (b -> IO ())
none = (b -> IO ()) -> Maybe (b -> IO ())
forall a. a -> Maybe a
Just ((b -> IO ()) -> Maybe (b -> IO ()))
-> (b -> IO ()) -> Maybe (b -> IO ())
forall a b. (a -> b) -> a -> b
$ IO () -> b -> IO ()
forall a b. a -> b -> a
const (IO () -> b -> IO ()) -> IO () -> b -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

cancelHandler :: (LspId -> IO ()) -> PartialHandlers config
cancelHandler :: (LspId -> IO ()) -> PartialHandlers config
cancelHandler LspId -> IO ()
cancelRequest = (WithMessage config -> Handlers -> IO Handlers)
-> PartialHandlers config
forall c.
(WithMessage c -> Handlers -> IO Handlers) -> PartialHandlers c
PartialHandlers ((WithMessage config -> Handlers -> IO Handlers)
 -> PartialHandlers config)
-> (WithMessage config -> Handlers -> IO Handlers)
-> PartialHandlers config
forall a b. (a -> b) -> a -> b
$ \WithMessage config
_ Handlers
x -> Handlers -> IO Handlers
forall (m :: * -> *) a. Monad m => a -> m a
return Handlers
x
    {cancelNotificationHandler :: Maybe (Handler CancelNotification)
LSP.cancelNotificationHandler = Handler CancelNotification -> Maybe (Handler CancelNotification)
forall a. a -> Maybe a
Just (Handler CancelNotification -> Maybe (Handler CancelNotification))
-> Handler CancelNotification -> Maybe (Handler CancelNotification)
forall a b. (a -> b) -> a -> b
$ \msg :: CancelNotification
msg@NotificationMessage {$sel:_params:NotificationMessage :: forall m a. NotificationMessage m a -> a
_params = CancelParams {LspId
$sel:_id:CancelParams :: CancelParams -> LspId
_id :: LspId
_id}} -> do
            LspId -> IO ()
cancelRequest LspId
_id
            Maybe (Handler CancelNotification)
-> (Handler CancelNotification -> IO ()) -> IO ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust (Handlers -> Maybe (Handler CancelNotification)
LSP.cancelNotificationHandler Handlers
x) (Handler CancelNotification -> Handler CancelNotification
forall a b. (a -> b) -> a -> b
$ CancelNotification
msg)
    }

exitHandler :: IO () -> PartialHandlers c
exitHandler :: IO () -> PartialHandlers c
exitHandler IO ()
exit = (WithMessage c -> Handlers -> IO Handlers) -> PartialHandlers c
forall c.
(WithMessage c -> Handlers -> IO Handlers) -> PartialHandlers c
PartialHandlers ((WithMessage c -> Handlers -> IO Handlers) -> PartialHandlers c)
-> (WithMessage c -> Handlers -> IO Handlers) -> PartialHandlers c
forall a b. (a -> b) -> a -> b
$ \WithMessage c
_ Handlers
x -> Handlers -> IO Handlers
forall (m :: * -> *) a. Monad m => a -> m a
return Handlers
x
    {exitNotificationHandler :: Maybe (Handler ExitNotification)
LSP.exitNotificationHandler = Handler ExitNotification -> Maybe (Handler ExitNotification)
forall a. a -> Maybe a
Just (Handler ExitNotification -> Maybe (Handler ExitNotification))
-> Handler ExitNotification -> Maybe (Handler ExitNotification)
forall a b. (a -> b) -> a -> b
$ IO () -> Handler ExitNotification
forall a b. a -> b -> a
const IO ()
exit}

-- | A message that we need to deal with - the pieces are split up with existentials to gain additional type safety

--   and defer precise processing until later (allows us to keep at a higher level of abstraction slightly longer)

data Message c
  = forall m req resp . (Show m, Show req, HasTracing req) =>
    Response (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp))
  | -- | Used for cases in which we need to send not only a response,

    --   but also an additional request to the client.

    --   For example, 'executeCommand' may generate an 'applyWorkspaceEdit' request.

    forall m rm req resp newReqParams newReqBody. (Show m, Show rm, Show req, HasTracing req) =>
    ResponseAndRequest (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (RequestMessage rm newReqParams newReqBody -> FromServerMessage) (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp, Maybe (rm, newReqParams)))
  | forall m req . (Show m, Show req, HasTracing req) =>
    Notification (NotificationMessage m req) (LSP.LspFuncs c -> IdeState -> req -> IO ())
  | -- | Used for the InitializeRequest only, where the response is generated by the LSP core handler.

    InitialParams InitializeRequest (LSP.LspFuncs c -> IdeState -> InitializeParams -> IO ())

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 SaveOptions
_save=SaveOptions -> Maybe SaveOptions
forall a. a -> Maybe a
Just (SaveOptions -> Maybe SaveOptions)
-> SaveOptions -> Maybe 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 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 SaveOptions
forall a. Maybe a
Nothing