git.iko.soy/ghcide
on de35c8f help sign in
ghcide/src/Development/IDE/LSP/LanguageServer.hs
187 lines 9.4 kB history raw
1-- Copyright (c) 2019 The DAML Authors. All rights reserved.
2-- SPDX-License-Identifier: Apache-2.0
4{-# LANGUAGE ExistentialQuantification #-}
6-- WARNING: A copy of DA.Daml.LanguageServer, try to keep them in sync
7-- This version removes the daml: handling
8module Development.IDE.LSP.LanguageServer
9 ( runLanguageServer
10 ) where
12import Language.Haskell.LSP.Types
13import Language.Haskell.LSP.Types.Capabilities
14import Development.IDE.LSP.Server
15import qualified Language.Haskell.LSP.Control as LSP
16import qualified Language.Haskell.LSP.Core as LSP
17import Control.Concurrent.Chan
18import Control.Concurrent.Extra
19import Control.Concurrent.Async
20import Control.Concurrent.STM
21import Control.Exception.Safe
22import Data.Default
23import Data.Maybe
24import qualified Data.Set as Set
25import qualified Data.Text as T
26import GHC.IO.Handle (hDuplicate, hDuplicateTo)
27import System.IO
28import Control.Monad.Extra
30import Development.IDE.LSP.Definition
31import Development.IDE.LSP.Hover
32import Development.IDE.LSP.CodeAction
33import Development.IDE.LSP.Notifications
34import Development.IDE.Core.Service
35import Development.IDE.Types.Logger
36import Development.IDE.Core.FileStore
37import Language.Haskell.LSP.Core (LspFuncs(..))
38import Language.Haskell.LSP.Messages
41runLanguageServer
42 :: LSP.Options
43 -> PartialHandlers
44 -> ((FromServerMessage -> IO ()) -> VFSHandle -> ClientCapabilities -> IO IdeState)
45 -> IO ()
46runLanguageServer options userHandlers getIdeState = do
47 -- Move stdout to another file descriptor and duplicate stderr
48 -- to stdout. This guards against stray prints from corrupting the JSON-RPC
49 -- message stream.
50 newStdout <- hDuplicate stdout
51 stderr `hDuplicateTo` stdout
52 hSetBuffering stderr NoBuffering
53 hSetBuffering stdout NoBuffering
55 -- Print out a single space to assert that the above redirection works.
56 -- This is interleaved with the logger, hence we just print a space here in
57 -- order not to mess up the output too much. Verified that this breaks
58 -- the language server tests without the redirection.
59 putStr " " >> hFlush stdout
61 -- Send everything over a channel, since you need to wait until after initialise before
62 -- LspFuncs is available
63 clientMsgChan :: Chan Message <- newChan
65 -- These barriers are signaled when the threads reading from these chans exit.
66 -- This should not happen but if it does, we will make sure that the whole server
67 -- dies and can be restarted instead of losing threads silently.
68 clientMsgBarrier <- newBarrier
70 -- The set of requests ids that we have received but not finished processing
71 pendingRequests <- newTVarIO Set.empty
72 -- The set of requests that have been cancelled and are also in pendingRequests
73 cancelledRequests <- newTVarIO Set.empty
75 let withResponse wrap f = Just $ \r@RequestMessage{_id} -> do
76 atomically $ modifyTVar pendingRequests (Set.insert _id)
77 writeChan clientMsgChan $ Response r wrap f
78 let withNotification old f = Just $ \r -> writeChan clientMsgChan $ Notification r (\lsp ide x -> f lsp ide x >> whenJust old ($ r))
79 let cancelRequest reqId = atomically $ do
80 queued <- readTVar pendingRequests
81 -- We want to avoid that the list of cancelled requests
82 -- keeps growing if we receive cancellations for requests
83 -- that do not exist or have already been processed.
84 when (reqId `elem` queued) $
85 modifyTVar cancelledRequests (Set.insert reqId)
86 let clearReqId reqId = atomically $ do
87 modifyTVar pendingRequests (Set.delete reqId)
88 modifyTVar cancelledRequests (Set.delete reqId)
89 -- We implement request cancellation by racing waitForCancel against
90 -- the actual request handler.
91 let waitForCancel reqId = atomically $ do
92 cancelled <- readTVar cancelledRequests
93 unless (reqId `Set.member` cancelled) retry
94 let PartialHandlers parts =
95 setHandlersIgnore <> -- least important
96 setHandlersDefinition <> setHandlersHover <> setHandlersCodeAction <> -- useful features someone may override
97 userHandlers <>
98 setHandlersNotifications <> -- absolutely critical, join them with user notifications
99 cancelHandler cancelRequest
100 -- Cancel requests are special since they need to be handled
101 -- out of order to be useful. Existing handlers are run afterwards.
102 handlers <- parts WithMessage{withResponse, withNotification} def
104 let initializeCallbacks = LSP.InitializeCallbacks
105 { LSP.onInitialConfiguration = const $ Right ()
106 , LSP.onConfigurationChange = const $ Right ()
107 , LSP.onStartup = handleInit (signalBarrier clientMsgBarrier ()) clearReqId waitForCancel clientMsgChan
108 }
110 void $ waitAnyCancel =<< traverse async
111 [ void $ LSP.runWithHandles
112 stdin
113 newStdout
114 initializeCallbacks
115 handlers
116 (modifyOptions options)
117 Nothing
118 , void $ waitBarrier clientMsgBarrier
119 ]
120 where
121 handleInit :: IO () -> (LspId -> IO ()) -> (LspId -> IO ()) -> Chan Message -> LSP.LspFuncs () -> IO (Maybe err)
122 handleInit exitClientMsg clearReqId waitForCancel clientMsgChan lspFuncs@LSP.LspFuncs{..} = do
123 ide <- getIdeState sendFunc (makeLSPVFSHandle lspFuncs) clientCapabilities
124 _ <- flip forkFinally (const exitClientMsg) $ forever $ do
125 msg <- readChan clientMsgChan
126 case msg of
127 Notification x@NotificationMessage{_params} act -> do
128 catch (act lspFuncs ide _params) $ \(e :: SomeException) ->
129 logError (ideLogger ide) $ T.pack $
130 "Unexpected exception on notification, please report!\n" ++
131 "Message: " ++ show x ++ "\n" ++
132 "Exception: " ++ show e
133 Response x@RequestMessage{_id, _params} wrap act ->
134 flip finally (clearReqId _id) $
135 catch (do
136 -- We could optimize this by first checking if the id
137 -- is in the cancelled set. However, this is unlikely to be a
138 -- bottleneck and the additional check might hide
139 -- issues with async exceptions that need to be fixed.
140 cancelOrRes <- race (waitForCancel _id) $ act lspFuncs ide _params
141 case cancelOrRes of
142 Left () -> do
143 logDebug (ideLogger ide) $ T.pack $
144 "Cancelled request " <> show _id
145 sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) Nothing $
146 Just $ ResponseError RequestCancelled "" Nothing
147 Right res ->
148 sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Just res) Nothing
149 ) $ \(e :: SomeException) -> do
150 logError (ideLogger ide) $ T.pack $
151 "Unexpected exception on request, please report!\n" ++
152 "Message: " ++ show x ++ "\n" ++
153 "Exception: " ++ show e
154 sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) Nothing $
155 Just $ ResponseError InternalError (T.pack $ show e) Nothing
156 pure Nothing
159-- | Things that get sent to us, but we don't deal with.
160-- Set them to avoid a warning in VS Code output.
161setHandlersIgnore :: PartialHandlers
162setHandlersIgnore = PartialHandlers $ \_ x -> return x
163 {LSP.initializedHandler = none
164 }
165 where none = Just $ const $ return ()
167cancelHandler :: (LspId -> IO ()) -> PartialHandlers
168cancelHandler cancelRequest = PartialHandlers $ \_ x -> return x
169 {LSP.cancelNotificationHandler = Just $ \msg@NotificationMessage {_params = CancelParams {_id}} -> do
170 cancelRequest _id
171 whenJust (LSP.cancelNotificationHandler x) ($ msg)
172 }
175-- | A message that we need to deal with - the pieces are split up with existentials to gain additional type safety
176-- and defer precise processing until later (allows us to keep at a higher level of abstraction slightly longer)
177data Message
178 = forall m req resp . (Show m, Show req) => Response (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (LSP.LspFuncs () -> IdeState -> req -> IO resp)
179 | forall m req . (Show m, Show req) => Notification (NotificationMessage m req) (LSP.LspFuncs () -> IdeState -> req -> IO ())
182modifyOptions :: LSP.Options -> LSP.Options
183modifyOptions x = x{LSP.textDocumentSync = Just $ tweak orig}
184 where
185 tweak x = x{_openClose=Just True, _change=Just TdSyncIncremental, _save=Just $ SaveOptions Nothing}
186 orig = fromMaybe tdsDefault $ LSP.textDocumentSync x
187 tdsDefault = TextDocumentSyncOptions Nothing Nothing Nothing Nothing Nothing