git.iko.soy/ghcide
on eddf78a help sign in
ghcide/src/Development/IDE/LSP/LanguageServer.hs
137 lines 6.3 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.Service.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.Exception.Safe
21import Data.Default
22import Data.Maybe
23import qualified Data.Text as T
24import GHC.IO.Handle (hDuplicate, hDuplicateTo)
25import System.IO
26import Control.Monad.Extra
28import Development.IDE.LSP.Definition
29import Development.IDE.LSP.Hover
30import Development.IDE.LSP.Notifications
31import Development.IDE.Core.Service
32import Development.IDE.Types.Logger
33import Development.IDE.Core.FileStore
34import Language.Haskell.LSP.Core (LspFuncs(..))
35import Language.Haskell.LSP.Messages
38runLanguageServer
39 :: LSP.Options
40 -> PartialHandlers
41 -> ((FromServerMessage -> IO ()) -> VFSHandle -> IO IdeState)
42 -> IO ()
43runLanguageServer options userHandlers getIdeState = do
44 -- Move stdout to another file descriptor and duplicate stderr
45 -- to stdout. This guards against stray prints from corrupting the JSON-RPC
46 -- message stream.
47 newStdout <- hDuplicate stdout
48 stderr `hDuplicateTo` stdout
49 hSetBuffering stderr NoBuffering
50 hSetBuffering stdout NoBuffering
52 -- Print out a single space to assert that the above redirection works.
53 -- This is interleaved with the logger, hence we just print a space here in
54 -- order not to mess up the output too much. Verified that this breaks
55 -- the language server tests without the redirection.
56 putStr " " >> hFlush stdout
58 -- Send everything over a channel, since you need to wait until after initialise before
59 -- LspFuncs is available
60 clientMsgChan :: Chan Message <- newChan
62 -- These barriers are signaled when the threads reading from these chans exit.
63 -- This should not happen but if it does, we will make sure that the whole server
64 -- dies and can be restarted instead of losing threads silently.
65 clientMsgBarrier <- newBarrier
67 let withResponse wrap f = Just $ \r -> writeChan clientMsgChan $ Response r wrap f
68 let withNotification old f = Just $ \r -> writeChan clientMsgChan $ Notification r (\ide x -> f ide x >> whenJust old ($ r))
69 let PartialHandlers parts =
70 setHandlersIgnore <> -- least important
71 setHandlersDefinition <> setHandlersHover <> -- useful features someone may override
72 userHandlers <>
73 setHandlersNotifications -- absolutely critical, join them with user notifications
74 handlers <- parts WithMessage{withResponse, withNotification} def
76 void $ waitAnyCancel =<< traverse async
77 [ void $ LSP.runWithHandles
78 stdin
79 newStdout
80 ( const $ Right ()
81 , handleInit (signalBarrier clientMsgBarrier ()) clientMsgChan
82 )
83 handlers
84 (modifyOptions options)
85 Nothing
86 , void $ waitBarrier clientMsgBarrier
87 ]
88 where
89 handleInit :: IO () -> Chan Message -> LSP.LspFuncs () -> IO (Maybe err)
90 handleInit exitClientMsg clientMsgChan lspFuncs@LSP.LspFuncs{..} = do
91 ide <- getIdeState sendFunc (makeLSPVFSHandle lspFuncs)
92 _ <- flip forkFinally (const exitClientMsg) $ forever $ do
93 msg <- readChan clientMsgChan
94 case msg of
95 Notification x@NotificationMessage{_params} act -> do
96 catch (act ide _params) $ \(e :: SomeException) ->
97 logError (ideLogger ide) $ T.pack $
98 "Unexpected exception on notification, please report!\n" ++
99 "Message: " ++ show x ++ "\n" ++
100 "Exception: " ++ show e
101 Response x@RequestMessage{_id, _params} wrap act ->
102 catch (do
103 res <- act ide _params
104 sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Just res) Nothing
105 ) $ \(e :: SomeException) -> do
106 logError (ideLogger ide) $ T.pack $
107 "Unexpected exception on request, please report!\n" ++
108 "Message: " ++ show x ++ "\n" ++
109 "Exception: " ++ show e
110 sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) Nothing $
111 Just $ ResponseError InternalError (T.pack $ show e) Nothing
112 pure Nothing
115-- | Things that get sent to us, but we don't deal with.
116-- Set them to avoid a warning in VS Code output.
117setHandlersIgnore :: PartialHandlers
118setHandlersIgnore = PartialHandlers $ \_ x -> return x
119 {LSP.cancelNotificationHandler = none
120 ,LSP.initializedHandler = none
121 }
122 where none = Just $ const $ return ()
125-- | A message that we need to deal with - the pieces are split up with existentials to gain additional type safety
126-- and defer precise processing until later (allows us to keep at a higher level of abstraction slightly longer)
127data Message
128 = forall m req resp . (Show m, Show req) => Response (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (IdeState -> req -> IO resp)
129 | forall m req . (Show m, Show req) => Notification (NotificationMessage m req) (IdeState -> req -> IO ())
132modifyOptions :: LSP.Options -> LSP.Options
133modifyOptions x = x{LSP.textDocumentSync = Just $ tweak orig}
134 where
135 tweak x = x{_openClose=Just True, _change=Just TdSyncIncremental, _save=Just $ SaveOptions Nothing}
136 orig = fromMaybe tdsDefault $ LSP.textDocumentSync x
137 tdsDefault = TextDocumentSyncOptions Nothing Nothing Nothing Nothing Nothing