Skip to content

Commit fa671cb

Browse files
neil-daneil-da
authored
Inline da-hs-language-server into haskell-ide-core (haskell/ghcide#1652)
* Inline da-hs-language-server into haskell-ide-core * Fix up the bazel file for new dependencies
1 parent df4e0ac commit fa671cb

File tree

3 files changed

+264
-0
lines changed

3 files changed

+264
-0
lines changed

‎BUILD.bazel

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -6,10 +6,12 @@ load("@os_info//:os_info.bzl", "is_windows")
66

77
depends = [
88
"aeson",
9+
"async",
910
"base",
1011
"binary",
1112
"bytestring",
1213
"containers",
14+
"data-default",
1315
"deepseq",
1416
"directory",
1517
"either",
@@ -21,6 +23,7 @@ depends = [
2123
"mtl",
2224
"network-uri",
2325
"pretty",
26+
"prettyprinter",
2427
"rope-utf16-splay",
2528
"safe-exceptions",
2629
"sorted-list",

‎ghcide/src/Development/IDE/LSP/Protocol.hs

Lines changed: 53 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,53 @@
1+
-- Copyright (c) 2019 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
2+
-- SPDX-License-Identifier: Apache-2.0
3+
4+
module Development.IDE.LSP.Protocol
5+
( module Language.Haskell.LSP.Types
6+
, ServerRequest(..)
7+
, ServerNotification(..)
8+
, prettyPosition
9+
) where
10+
11+
import qualified Data.Aeson as Aeson
12+
import qualified Data.Text as T
13+
import Data.Text.Prettyprint.Doc
14+
15+
import Language.Haskell.LSP.Types hiding
16+
( CodeLens
17+
, DocumentSymbol
18+
, Hover
19+
, Shutdown
20+
, SignatureHelp
21+
, WorkspaceSymbol
22+
)
23+
24+
-- | Request sent by the client to the server.
25+
data ServerRequest
26+
= Shutdown
27+
| KeepAlive
28+
| Completion !CompletionParams
29+
| SignatureHelp !TextDocumentPositionParams
30+
| Hover !TextDocumentPositionParams
31+
| Definition !TextDocumentPositionParams
32+
| References !ReferenceParams
33+
| CodeLens !CodeLensParams
34+
| Rename !RenameParams
35+
| DocumentSymbol !DocumentSymbolParams
36+
| WorkspaceSymbol !WorkspaceSymbolParams
37+
| Formatting !DocumentFormattingParams
38+
| UnknownRequest !T.Text !Aeson.Value
39+
deriving Show
40+
41+
data ServerNotification
42+
= DidOpenTextDocument DidOpenTextDocumentParams
43+
| DidChangeTextDocument DidChangeTextDocumentParams
44+
| DidCloseTextDocument DidCloseTextDocumentParams
45+
| DidSaveTextDocument DidSaveTextDocumentParams
46+
| UnknownNotification T.Text Aeson.Value
47+
48+
----------------------------------------------------------------------------------------------------
49+
-- Pretty printing
50+
----------------------------------------------------------------------------------------------------
51+
52+
prettyPosition :: Position -> Doc a
53+
prettyPosition Position{..} = pretty (_line + 1) <> colon <> pretty (_character + 1)

‎ghcide/src/Development/IDE/LSP/Server.hs

Lines changed: 208 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,208 @@
1+
-- Copyright (c) 2019 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
2+
-- SPDX-License-Identifier: Apache-2.0
3+
4+
{-# LANGUAGE DuplicateRecordFields #-}
5+
{-# LANGUAGE OverloadedStrings #-}
6+
{-# LANGUAGE RankNTypes #-}
7+
module Development.IDE.LSP.Server
8+
( runServer
9+
, Handlers(..)
10+
) where
11+
12+
13+
import Control.Monad
14+
import Control.Concurrent
15+
import Control.Concurrent.Async
16+
import Control.Concurrent.Extra
17+
import Control.Concurrent.STM
18+
19+
import Data.Default
20+
21+
import Development.IDE.LSP.Protocol
22+
import qualified Development.IDE.Logger as Logger
23+
24+
import qualified Data.Aeson as Aeson
25+
import qualified Data.Aeson.Text as Aeson
26+
import qualified Data.Text.Lazy as TL
27+
import qualified Data.Text as T
28+
29+
import System.IO
30+
import GHC.IO.Handle (hDuplicate, hDuplicateTo)
31+
32+
import qualified Language.Haskell.LSP.Control as LSP
33+
import qualified Language.Haskell.LSP.Core as LSP
34+
import qualified Language.Haskell.LSP.Messages as LSP
35+
import qualified Language.Haskell.LSP.Types as LSP
36+
37+
------------------------------------------------------------------------
38+
-- Server execution
39+
------------------------------------------------------------------------
40+
41+
data 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+
}
50+
51+
runServer
52+
:: Logger.Handle
53+
-> (LSP.LspFuncs () -> IO Handlers)
54+
-- ^ Notification handler for language server notifications
55+
-> IO ()
56+
runServer 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
62+
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 -> Logger.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
100+
101+
convClientMsg :: LSP.FromClientMessage -> Maybe (Either ServerNotification (ServerRequest, LspId))
102+
convClientMsg msg = case msg of
103+
LSP.ReqInitialize m -> unknownReq m
104+
LSP.ReqShutdown m -> Just $ Right (Shutdown, reqId m)
105+
106+
LSP.ReqHover m -> toReq Hover m
107+
108+
LSP.ReqCompletion m -> toReq Completion m
109+
LSP.ReqCompletionItemResolve m -> unknownReq m
110+
111+
LSP.ReqSignatureHelp m -> toReq SignatureHelp m
112+
113+
LSP.ReqDefinition m -> toReq Definition m
114+
LSP.ReqTypeDefinition m -> toReq Definition m
115+
LSP.ReqImplementation m -> toReq Definition m
116+
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
122+
123+
LSP.ReqCodeLens m -> toReq CodeLens m
124+
LSP.ReqCodeLensResolve m -> unknownReq m
125+
126+
LSP.ReqDocumentLink m -> unknownReq m
127+
LSP.ReqDocumentLinkResolve m -> unknownReq m
128+
LSP.ReqDocumentColor m -> unknownReq m
129+
LSP.ReqColorPresentation m -> unknownReq m
130+
131+
LSP.ReqDocumentFormatting m -> toReq Formatting m
132+
LSP.ReqDocumentRangeFormatting m -> unknownReq m
133+
LSP.ReqDocumentOnTypeFormatting m -> unknownReq m
134+
135+
LSP.ReqRename m -> toReq Rename m
136+
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
143+
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
157+
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
175+
176+
handlers :: TChan LSP.FromClientMessage -> LSP.Handlers
177+
handlers 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
197+
198+
options :: LSP.Options
199+
options = 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+
}

0 commit comments

Comments
 (0)