@@ -2,39 +2,18 @@
22-- SPDX-License-Identifier: Apache-2.0
33
44{-# LANGUAGE DuplicateRecordFields #-}
5−{-# LANGUAGE OverloadedStrings #-}
65{-# LANGUAGE RankNTypes #-}
76module Development.IDE.LSP.Server
8− ( runServer
9− , Handlers(..)
10− , WithMessage(..)
7+ ( WithMessage(..)
118 , PartialHandlers(..)
129 ) where
1310
1411
15−import Control.Monad
16−import Control.Concurrent
17−import Control.Concurrent.Async
18−import Control.Concurrent.Extra
19−import Control.Concurrent.STM
20−
2112import Data.Default
2213
23−import Development.IDE.LSP.Protocol
24−import Development.IDE.Types.Logger
25−
26−import qualified Data.Aeson as Aeson
27−import qualified Data.Aeson.Text as Aeson
28−import qualified Data.Text.Lazy as TL
29−import qualified Data.Text as T
30−
31−import System.IO
32−import GHC.IO.Handle (hDuplicate, hDuplicateTo)
33−
34−import qualified Language.Haskell.LSP.Control as LSP
14+import Language.Haskell.LSP.Types
3515import qualified Language.Haskell.LSP.Core as LSP
3616import qualified Language.Haskell.LSP.Messages as LSP
37−import qualified Language.Haskell.LSP.Types as LSP
3817import Development.IDE.Core.Service
3918
4019
@@ -59,176 +38,3 @@ instance Semigroup PartialHandlers where
5938
6039instance Monoid PartialHandlers where
6140 mempty = def
62−
63−------------------------------------------------------------------------
64−-- Server execution
65−------------------------------------------------------------------------
66−
67−data Handlers = Handlers
68− { requestHandler
69− :: (forall resp. resp -> ResponseMessage resp)
70− -> (ErrorCode -> ResponseMessage ())
71− -> ServerRequest
72− -> IO LSP.FromServerMessage
73− , notificationHandler
74− :: ServerNotification -> IO ()
75− }
76−
77−runServer
78− :: Logger
79− -> (LSP.LspFuncs () -> IO Handlers)
80− -- ^ Notification handler for language server notifications
81− -> IO ()
82−runServer loggerH getHandlers = do
83− -- DEL-6257: Move stdout to another file descriptor and duplicate stderr
84− -- to stdout. This guards against stray prints from corrupting the JSON-RPC
85− -- message stream.
86− newStdout <- hDuplicate stdout
87− stderr `hDuplicateTo` stdout
88−
89− -- Print out a single space to assert that the above redirection works.
90− -- This is interleaved with the logger, hence we just print a space here in
91− -- order not to mess up the output too much. Verified that this breaks
92− -- the language server tests without the redirection.
93− putStr " " >> hFlush stdout
94− clientMsgChan <- newTChanIO
95− -- These barriers are signaled when the threads reading from these chans exit.
96− -- This should not happen but if it does, we will make sure that the whole server
97− -- dies and can be restarted instead of losing threads silently.
98− clientMsgBarrier <- newBarrier
99− void $ waitAnyCancel =<< traverse async
100− [ void $ LSP.runWithHandles
101− stdin
102− newStdout
103− ( const $ Right ()
104− , handleInit (signalBarrier clientMsgBarrier ()) clientMsgChan
105− )
106− (handlers clientMsgChan)
107− options
108− Nothing
109− , void $ waitBarrier clientMsgBarrier
110− ]
111− where
112− handleInit :: IO () -> TChan LSP.FromClientMessage -> LSP.LspFuncs () -> IO (Maybe LSP.ResponseError)
113− handleInit exitClientMsg clientMsgChan lspFuncs@LSP.LspFuncs{..} = do
114− Handlers{..} <- getHandlers lspFuncs
115− let requestHandler' (req, reqId) = requestHandler
116− (\res -> ResponseMessage "2.0" (responseId reqId) (Just res) Nothing)
117− (\err -> ResponseMessage "2.0" (responseId reqId) Nothing (Just $ ResponseError err "" Nothing))
118− req
119− _ <- flip forkFinally (const exitClientMsg) $ forever $ do
120− msg <- atomically $ readTChan clientMsgChan
121− case convClientMsg msg of
122− Nothing -> logSeriousError loggerH $ "Unknown client msg: " <> T.pack (show msg)
123− Just (Left notif) -> notificationHandler notif
124− Just (Right req) -> sendFunc =<< requestHandler' req
125− pure Nothing
126−
127−convClientMsg :: LSP.FromClientMessage -> Maybe (Either ServerNotification (ServerRequest, LspId))
128−convClientMsg msg = case msg of
129− LSP.ReqInitialize m -> unknownReq m
130− LSP.ReqShutdown m -> Just $ Right (Shutdown, reqId m)
131−
132− LSP.ReqHover m -> toReq Hover m
133−
134− LSP.ReqCompletion m -> toReq Completion m
135− LSP.ReqCompletionItemResolve m -> unknownReq m
136−
137− LSP.ReqSignatureHelp m -> toReq SignatureHelp m
138−
139− LSP.ReqDefinition m -> toReq Definition m
140− LSP.ReqTypeDefinition m -> toReq Definition m
141− LSP.ReqImplementation m -> toReq Definition m
142−
143− LSP.ReqFindReferences m -> toReq References m
144− LSP.ReqDocumentHighlights m -> unknownReq m
145− LSP.ReqDocumentSymbols m -> toReq DocumentSymbol m
146− LSP.ReqWorkspaceSymbols m -> toReq WorkspaceSymbol m
147− LSP.ReqCodeAction m -> unknownReq m
148−
149− LSP.ReqCodeLens m -> toReq CodeLens m
150− LSP.ReqCodeLensResolve m -> unknownReq m
151−
152− LSP.ReqDocumentLink m -> unknownReq m
153− LSP.ReqDocumentLinkResolve m -> unknownReq m
154− LSP.ReqDocumentColor m -> unknownReq m
155− LSP.ReqColorPresentation m -> unknownReq m
156−
157− LSP.ReqDocumentFormatting m -> toReq Formatting m
158− LSP.ReqDocumentRangeFormatting m -> unknownReq m
159− LSP.ReqDocumentOnTypeFormatting m -> unknownReq m
160−
161− LSP.ReqRename m -> toReq Rename m
162−
163− LSP.ReqFoldingRange m -> unknownReq m
164− LSP.ReqExecuteCommand m -> unknownReq m
165− LSP.ReqWillSaveWaitUntil m -> unknownReq m
166− LSP.ReqCustomClient m -> case reqMethod m of
167− CustomClientMethod "daml/keepAlive" -> Just $ Right (KeepAlive, reqId m)
168− _ -> unknownReq m
169−
170− LSP.NotInitialized m -> unknownNot m
171− LSP.NotExit m -> unknownNot m
172− LSP.NotCancelRequestFromClient m -> unknownNot m
173− LSP.NotDidChangeConfiguration m -> unknownNot m
174− LSP.NotDidOpenTextDocument m -> toNot DidOpenTextDocument m
175− LSP.NotDidChangeTextDocument m -> toNot DidChangeTextDocument m
176− LSP.NotDidCloseTextDocument m -> toNot DidCloseTextDocument m
177− LSP.NotWillSaveTextDocument m -> unknownNot m
178− LSP.NotDidSaveTextDocument m -> toNot DidSaveTextDocument m
179− LSP.NotDidChangeWatchedFiles m -> unknownNot m
180− LSP.NotDidChangeWorkspaceFolders m -> unknownNot m
181− LSP.NotProgressCancel m -> unknownNot m
182− LSP.NotCustomClient m -> unknownNot m
183−
184− LSP.RspApplyWorkspaceEdit _ -> Nothing
185− LSP.RspFromClient _ -> Nothing
186− where toReq constr msg = Just $ Right (constr $ reqParams msg, reqId msg)
187− toNot constr msg = Just $ Left $ constr $ notParams msg
188− unknownReq (LSP.RequestMessage _ id method params) =
189− Just $ Right (UnknownRequest (TL.toStrict $ Aeson.encodeToLazyText method) (Aeson.toJSON params), id)
190− unknownNot (LSP.NotificationMessage _ method params) =
191− Just $ Left $ UnknownNotification (TL.toStrict $ Aeson.encodeToLazyText method) (Aeson.toJSON params)
192− -- Type-restricted wrappers to make DuplicateRecordFields less annoying.
193− reqParams :: RequestMessage m req resp -> req
194− reqParams = _params
195− reqId :: RequestMessage m req resp -> LspId
196− reqId = _id
197− reqMethod :: RequestMessage m req resp -> m
198− reqMethod = _method
199− notParams :: NotificationMessage m a -> a
200− notParams = _params
201−
202−handlers :: TChan LSP.FromClientMessage -> LSP.Handlers
203−handlers chan = def
204− { LSP.hoverHandler = emit LSP.ReqHover
205− , LSP.definitionHandler = emit LSP.ReqDefinition
206− , LSP.codeLensHandler = emit LSP.ReqCodeLens
207− , LSP.didOpenTextDocumentNotificationHandler = emit LSP.NotDidOpenTextDocument
208− , LSP.didChangeTextDocumentNotificationHandler = emit LSP.NotDidChangeTextDocument
209− , LSP.didCloseTextDocumentNotificationHandler = emit LSP.NotDidCloseTextDocument
210− , LSP.didSaveTextDocumentNotificationHandler = emit LSP.NotDidSaveTextDocument
211− , LSP.initializedHandler = emit LSP.NotInitialized
212− , LSP.exitNotificationHandler = Nothing
213− -- If the exit notification handler is set to `Nothing`
214− -- haskell-lsp will take care of shutting down the server for us.
215− , LSP.customRequestHandler = emit LSP.ReqCustomClient
216− , LSP.cancelNotificationHandler = Just $ const $ pure ()
217− -- ^ We just ignore cancel requests which is allowed according to
218− -- the spec. Installing a handler avoids errors about the missing handler.
219− }
220− where
221− emit :: (a -> LSP.FromClientMessage) -> Maybe (LSP.Handler a)
222− emit f = Just $ atomically . writeTChan chan . f
223−
224−options :: LSP.Options
225−options = def
226− { LSP.textDocumentSync = Just TextDocumentSyncOptions
227− { _openClose = Just True
228− , _change = Just TdSyncIncremental
229− , _willSave = Nothing
230− , _willSaveWaitUntil = Nothing
231− , _save = Just $ SaveOptions $ Just False
232− }
233− , LSP.codeLensProvider = Just $ CodeLensOptions $ Just False
234− }