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