@@ -39,11 +39,14 @@ import Language.Haskell.LSP.Core (LspFuncs(..))
3939import Language.Haskell.LSP.Messages
4040
4141runLanguageServer
42− :: LSP.Options
43− -> PartialHandlers
42+ :: forall config. (Show config)
43+ => LSP.Options
44+ -> PartialHandlers config
45+ -> (InitializeRequest -> Either T.Text config)
46+ -> (DidChangeConfigurationNotification -> Either T.Text config)
4447 -> (IO LspId -> (FromServerMessage -> IO ()) -> VFSHandle -> ClientCapabilities -> IO IdeState)
4548 -> IO ()
46−runLanguageServer options userHandlers getIdeState = do
49+runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeState = do
4750 -- Move stdout to another file descriptor and duplicate stderr
4851 -- to stdout. This guards against stray prints from corrupting the JSON-RPC
4952 -- message stream.
@@ -60,7 +63,7 @@ runLanguageServer options userHandlers getIdeState = do
6063
6164 -- Send everything over a channel, since you need to wait until after initialise before
6265 -- LspFuncs is available
63− clientMsgChan :: Chan Message <- newChan
66+ clientMsgChan :: Chan (Message config) <- newChan
6467
6568 -- These barriers are signaled when the threads reading from these chans exit.
6669 -- This should not happen but if it does, we will make sure that the whole server
@@ -79,6 +82,7 @@ runLanguageServer options userHandlers getIdeState = do
7982 let withResponseAndRequest wrap wrapNewReq f = Just $ \r@RequestMessage{_id} -> do
8083 atomically $ modifyTVar pendingRequests (Set.insert _id)
8184 writeChan clientMsgChan $ ResponseAndRequest r wrap wrapNewReq f
85+ let withInitialize f = Just $ \r -> writeChan clientMsgChan $ InitialParams r (\lsp ide x -> f lsp ide x)
8286 let cancelRequest reqId = atomically $ do
8387 queued <- readTVar pendingRequests
8488 -- We want to avoid that the list of cancelled requests
@@ -95,6 +99,7 @@ runLanguageServer options userHandlers getIdeState = do
9599 cancelled <- readTVar cancelledRequests
96100 unless (reqId `Set.member` cancelled) retry
97101 let PartialHandlers parts =
102+ initializeRequestHandler <>
98103 setHandlersIgnore <> -- least important
99104 setHandlersDefinition <> setHandlersHover <>
100105 setHandlersOutline <>
@@ -103,11 +108,11 @@ runLanguageServer options userHandlers getIdeState = do
103108 cancelHandler cancelRequest
104109 -- Cancel requests are special since they need to be handled
105110 -- out of order to be useful. Existing handlers are run afterwards.
106− handlers <- parts WithMessage{withResponse, withNotification, withResponseAndRequest} def
111+ handlers <- parts WithMessage{withResponse, withNotification, withResponseAndRequest, withInitialize} def
107112
108113 let initializeCallbacks = LSP.InitializeCallbacks
109− { LSP.onInitialConfiguration = Right . parseConfiguration
110− , LSP.onConfigurationChange = const $ Left "Configuration changes not supported yet"
114+ { LSP.onInitialConfiguration = onInitialConfig
115+ , LSP.onConfigurationChange = onConfigChange
111116 , LSP.onStartup = handleInit (signalBarrier clientMsgBarrier ()) clearReqId waitForCancel clientMsgChan
112117 }
113118
@@ -122,13 +127,11 @@ runLanguageServer options userHandlers getIdeState = do
122127 , void $ waitBarrier clientMsgBarrier
123128 ]
124129 where
125− handleInit :: IO () -> (LspId -> IO ()) -> (LspId -> IO ()) -> Chan Message -> LSP.LspFuncs IdeConfiguration -> IO (Maybe err)
130+ handleInit :: IO () -> (LspId -> IO ()) -> (LspId -> IO ()) -> Chan (Message config) -> LSP.LspFuncs config -> IO (Maybe err)
126131 handleInit exitClientMsg clearReqId waitForCancel clientMsgChan lspFuncs@LSP.LspFuncs{..} = do
127132
128133 ide <- getIdeState getNextReqId sendFunc (makeLSPVFSHandle lspFuncs) clientCapabilities
129134
130− mapM_ (registerIdeConfiguration (shakeExtras ide)) =<< config
131−
132135 _ <- flip forkFinally (const exitClientMsg) $ forever $ do
133136 msg <- readChan clientMsgChan
134137 case msg of
@@ -152,6 +155,12 @@ runLanguageServer options userHandlers getIdeState = do
152155 Just (rm, newReqParams) -> do
153156 reqId <- getNextReqId
154157 sendFunc $ wrapNewReq $ RequestMessage "2.0" reqId rm newReqParams
158+ InitialParams x@RequestMessage{_id, _params} act -> do
159+ catch (act lspFuncs ide _params) $ \(e :: SomeException) ->
160+ logError (ideLogger ide) $ T.pack $
161+ "Unexpected exception on InitializeRequest handler, please report!\n" ++
162+ "Message: " ++ show x ++ "\n" ++
163+ "Exception: " ++ show e
155164 pure Nothing
156165
157166 checkCancelled ide clearReqId waitForCancel lspFuncs@LSP.LspFuncs{..} wrap act msg _id _params k =
@@ -177,17 +186,28 @@ runLanguageServer options userHandlers getIdeState = do
177186 sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) Nothing $
178187 Just $ ResponseError InternalError (T.pack $ show e) Nothing
179188
189+initializeRequestHandler :: PartialHandlers config
190+initializeRequestHandler = PartialHandlers $ \WithMessage{..} x -> return x{
191+ LSP.initializeRequestHandler = withInitialize initHandler
192+ }
193+
194+initHandler
195+ :: LSP.LspFuncs c
196+ -> IdeState
197+ -> InitializeParams
198+ -> IO ()
199+initHandler _ ide params = registerIdeConfiguration (shakeExtras ide) (parseConfiguration params)
180200
181201-- | Things that get sent to us, but we don't deal with.
182202-- Set them to avoid a warning in VS Code output.
183−setHandlersIgnore :: PartialHandlers
203+setHandlersIgnore :: PartialHandlers config
184204setHandlersIgnore = PartialHandlers $ \_ x -> return x
185205 {LSP.initializedHandler = none
186206 ,LSP.responseHandler = none
187207 }
188208 where none = Just $ const $ return ()
189209
190−cancelHandler :: (LspId -> IO ()) -> PartialHandlers
210+cancelHandler :: (LspId -> IO ()) -> PartialHandlers config
191211cancelHandler cancelRequest = PartialHandlers $ \_ x -> return x
192212 {LSP.cancelNotificationHandler = Just $ \msg@NotificationMessage {_params = CancelParams {_id}} -> do
193213 cancelRequest _id
@@ -197,14 +217,15 @@ cancelHandler cancelRequest = PartialHandlers $ \_ x -> return x
197217
198218-- | A message that we need to deal with - the pieces are split up with existentials to gain additional type safety
199219-- and defer precise processing until later (allows us to keep at a higher level of abstraction slightly longer)
200−data Message
201− = forall m req resp . (Show m, Show req) => Response (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (LSP.LspFuncs IdeConfiguration -> IdeState -> req -> IO (Either ResponseError resp))
220+data Message c
221+ = forall m req resp . (Show m, Show req) => Response (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp))
202222 -- | Used for cases in which we need to send not only a response,
203223 -- but also an additional request to the client.
204224 -- For example, 'executeCommand' may generate an 'applyWorkspaceEdit' request.
205− | 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 IdeConfiguration -> IdeState -> req -> IO (resp, Maybe (rm, newReqParams)))
206− | forall m req . (Show m, Show req) => Notification (NotificationMessage m req) (LSP.LspFuncs IdeConfiguration -> IdeState -> req -> IO ())
207−
225+ | 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 c -> IdeState -> req -> IO (resp, Maybe (rm, newReqParams)))
226+ | forall m req . (Show m, Show req) => Notification (NotificationMessage m req) (LSP.LspFuncs c -> IdeState -> req -> IO ())
227+ -- | Used for the InitializeRequest only, where the response is generated by the LSP core handler.
228+ | InitialParams InitializeRequest (LSP.LspFuncs c -> IdeState -> InitializeParams -> IO ())
208229
209230modifyOptions :: LSP.Options -> LSP.Options
210231modifyOptions x = x{ LSP.textDocumentSync = Just $ tweakTDS origTDS