git.iko.soy/ghcide
on 2a7aaa9 help sign in
ghcide/src/Development/IDE/LSP/LanguageServer.hs
183 lines 9.1 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 OverloadedStrings #-}
5{-# LANGUAGE ExistentialQuantification #-}
7-- WARNING: A copy of DA.Daml.LanguageServer, try to keep them in sync
8-- This version removes the daml: handling
9module Development.IDE.LSP.LanguageServer
10 ( runLanguageServer
11 ) where
13import Language.Haskell.LSP.Types
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 -> 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 void $ waitAnyCancel =<< traverse async
105 [ void $ LSP.runWithHandles
106 stdin
107 newStdout
108 ( const $ Right ()
109 , handleInit (signalBarrier clientMsgBarrier ()) clearReqId waitForCancel clientMsgChan
110 )
111 handlers
112 (modifyOptions options)
113 Nothing
114 , void $ waitBarrier clientMsgBarrier
115 ]
116 where
117 handleInit :: IO () -> (LspId -> IO ()) -> (LspId -> IO ()) -> Chan Message -> LSP.LspFuncs () -> IO (Maybe err)
118 handleInit exitClientMsg clearReqId waitForCancel clientMsgChan lspFuncs@LSP.LspFuncs{..} = do
119 ide <- getIdeState sendFunc (makeLSPVFSHandle lspFuncs)
120 _ <- flip forkFinally (const exitClientMsg) $ forever $ do
121 msg <- readChan clientMsgChan
122 case msg of
123 Notification x@NotificationMessage{_params} act -> do
124 catch (act lspFuncs ide _params) $ \(e :: SomeException) ->
125 logError (ideLogger ide) $ T.pack $
126 "Unexpected exception on notification, please report!\n" ++
127 "Message: " ++ show x ++ "\n" ++
128 "Exception: " ++ show e
129 Response x@RequestMessage{_id, _params} wrap act ->
130 flip finally (clearReqId _id) $
131 catch (do
132 -- We could optimize this by first checking if the id
133 -- is in the cancelled set. However, this is unlikely to be a
134 -- bottleneck and the additional check might hide
135 -- issues with async exceptions that need to be fixed.
136 cancelOrRes <- race (waitForCancel _id) $ act lspFuncs ide _params
137 case cancelOrRes of
138 Left () -> do
139 logDebug (ideLogger ide) $ T.pack $
140 "Cancelled request " <> show _id
141 sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) Nothing $
142 Just $ ResponseError RequestCancelled "" Nothing
143 Right res ->
144 sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Just res) Nothing
145 ) $ \(e :: SomeException) -> do
146 logError (ideLogger ide) $ T.pack $
147 "Unexpected exception on request, please report!\n" ++
148 "Message: " ++ show x ++ "\n" ++
149 "Exception: " ++ show e
150 sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) Nothing $
151 Just $ ResponseError InternalError (T.pack $ show e) Nothing
152 pure Nothing
155-- | Things that get sent to us, but we don't deal with.
156-- Set them to avoid a warning in VS Code output.
157setHandlersIgnore :: PartialHandlers
158setHandlersIgnore = PartialHandlers $ \_ x -> return x
159 {LSP.initializedHandler = none
160 }
161 where none = Just $ const $ return ()
163cancelHandler :: (LspId -> IO ()) -> PartialHandlers
164cancelHandler cancelRequest = PartialHandlers $ \_ x -> return x
165 {LSP.cancelNotificationHandler = Just $ \msg@NotificationMessage {_params = CancelParams {_id}} -> do
166 cancelRequest _id
167 whenJust (LSP.cancelNotificationHandler x) ($ msg)
168 }
171-- | A message that we need to deal with - the pieces are split up with existentials to gain additional type safety
172-- and defer precise processing until later (allows us to keep at a higher level of abstraction slightly longer)
173data Message
174 = forall m req resp . (Show m, Show req) => Response (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (LSP.LspFuncs () -> IdeState -> req -> IO resp)
175 | forall m req . (Show m, Show req) => Notification (NotificationMessage m req) (LSP.LspFuncs () -> IdeState -> req -> IO ())
178modifyOptions :: LSP.Options -> LSP.Options
179modifyOptions x = x{LSP.textDocumentSync = Just $ tweak orig}
180 where
181 tweak x = x{_openClose=Just True, _change=Just TdSyncIncremental, _save=Just $ SaveOptions Nothing}
182 orig = fromMaybe tdsDefault $ LSP.textDocumentSync x
183 tdsDefault = TextDocumentSyncOptions Nothing Nothing Nothing Nothing Nothing