@@ -1,9 +1,8 @@
11-- Copyright (c) 2019 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
22-- SPDX-License-Identifier: Apache-2.0
33
4−{-# LANGUAGE DuplicateRecordFields #-}
54{-# LANGUAGE OverloadedStrings #-}
6−{-# LANGUAGE RankNTypes #-}
5+{-# LANGUAGE ExistentialQuantification #-}
76
87-- WARNING: A copy of DA.Service.Daml.LanguageServer, try to keep them in sync
98-- This version removes the daml: handling
@@ -11,145 +10,114 @@ module Development.IDE.LSP.LanguageServer
1110 ( runLanguageServer
1211 ) where
1312
14−import Development.IDE.LSP.Protocol
15−import Development.IDE.LSP.Server
16−
17−import Control.Monad.IO.Class
18−import qualified Development.IDE.LSP.Definition as LS.Definition
19−import qualified Development.IDE.LSP.Hover as LS.Hover
20−import Development.IDE.Types.Logger
13+import Language.Haskell.LSP.Types
14+import Development.IDE.LSP.Server hiding (runServer)
15+import qualified Language.Haskell.LSP.Control as LSP
16+import qualified Language.Haskell.LSP.Core as LSP
17+import Control.Concurrent.Chan
18+import Control.Concurrent.Extra
19+import Control.Concurrent.Async
20+import Data.Default
21+import GHC.IO.Handle (hDuplicate, hDuplicateTo)
22+import System.IO
23+import Control.Monad
24+
25+import Development.IDE.LSP.Definition
26+import Development.IDE.LSP.Hover
27+import Development.IDE.LSP.Notifications
2128import Development.IDE.Core.Service
22−import Development.IDE.Types.Location
23−
24−import qualified Data.Aeson as Aeson
25−import qualified Data.Rope.UTF16 as Rope
26−import qualified Data.Set as S
27−import qualified Data.Text as T
28−
2929import Development.IDE.Core.FileStore
30−import Development.IDE.Core.OfInterest
31−
32−import qualified Network.URI as URI
33−
34−import qualified System.Exit
35−
3630import Language.Haskell.LSP.Core (LspFuncs(..))
3731import Language.Haskell.LSP.Messages
38−import Language.Haskell.LSP.VFS
39−
40−textShow :: Show a => a -> T.Text
41−textShow = T.pack . show
42−
43−------------------------------------------------------------------------
44−-- Request handlers
45−------------------------------------------------------------------------
46−
47−handleRequest
48− :: Logger
49− -> IdeState
50− -> (forall resp. resp -> ResponseMessage resp)
51− -> (ErrorCode -> ResponseMessage ())
52− -> ServerRequest
53− -> IO FromServerMessage
54−handleRequest logger compilerH makeResponse makeErrorResponse = \case
55− Shutdown -> do
56− logInfo logger "Shutdown request received, terminating."
57− System.Exit.exitSuccess
58−
59− KeepAlive -> pure $ RspCustomServer $ makeResponse Aeson.Null
60−
61− Definition params -> RspDefinition . makeResponse <$> LS.Definition.handle logger compilerH params
62− Hover params -> RspHover . makeResponse <$> LS.Hover.handle logger compilerH params
63− CodeLens _params -> pure $ RspCodeLens $ makeResponse mempty
64−
65− req -> do
66− logWarning logger ("Method not found" <> T.pack (show req))
67− pure $ RspError $ makeErrorResponse MethodNotFound
68−
69−
70−handleNotification :: LspFuncs () -> Logger -> IdeState -> ServerNotification -> IO ()
71−handleNotification lspFuncs logger compilerH = \case
72−
73− DidOpenTextDocument (DidOpenTextDocumentParams item) -> do
74− case URI.parseURI $ T.unpack $ getUri $ _uri (item :: TextDocumentItem) of
75− Just uri
76− | URI.uriScheme uri == "file:"
77− -> handleDidOpenFile item
78−
79− | otherwise
80− -> logWarning logger $ "Unknown scheme in URI: "
81− <> textShow uri
82−
83− _ -> logSeriousError logger $ "Invalid URI in DidOpenTextDocument: "
84− <> textShow (_uri (item :: TextDocumentItem))
85−
86− DidChangeTextDocument (DidChangeTextDocumentParams docId _) -> do
87− let uri = _uri (docId :: VersionedTextDocumentIdentifier)
88−
89− case uriToFilePath' uri of
90− Just (toNormalizedFilePath -> filePath) -> do
91− mbVirtual <- getVirtualFileFunc lspFuncs $ toNormalizedUri uri
92− let contents = maybe "" (Rope.toText . (_text :: VirtualFile -> Rope.Rope)) mbVirtual
93− onFileModified compilerH filePath (Just contents)
94− logInfo logger
95− $ "Updated text document: " <> textShow (fromNormalizedFilePath filePath)
96−
97− Nothing ->
98− logSeriousError logger
99− $ "Invalid file path: " <> textShow (_uri (docId :: VersionedTextDocumentIdentifier))
100−
101− DidCloseTextDocument (DidCloseTextDocumentParams (TextDocumentIdentifier uri)) ->
102− case URI.parseURI $ T.unpack $ getUri uri of
103− Just uri'
104− | URI.uriScheme uri' == "file:" -> do
105− Just fp <- pure $ toNormalizedFilePath <$> uriToFilePath' uri
106− handleDidCloseFile fp
107− | otherwise -> logWarning logger $ "Unknown scheme in URI: " <> textShow uri
108−
109− _ -> logSeriousError logger
110− $ "Invalid URI in DidCloseTextDocument: "
111− <> textShow uri
112−
113− DidSaveTextDocument _params ->
114− pure ()
115−
116− UnknownNotification _method _params -> return ()
117− where
118− -- Note that the state changes here are not atomic.
119− -- When we have parallel compilation we could manage the state
120− -- changes in STM so that we can atomically change the state.
121− -- Internally it should be done via the IO oracle. See PROD-2808.
122− handleDidOpenFile (TextDocumentItem uri _ _ contents) = do
123− Just filePath <- pure $ toNormalizedFilePath <$> uriToFilePath' uri
124− onFileModified compilerH filePath (Just contents)
125− modifyFilesOfInterest compilerH (S.insert filePath)
126− logInfo logger $ "Opened text document: " <> textShow filePath
127−
128− handleDidCloseFile filePath = do
129− logInfo logger $ "Closed text document: " <> textShow (fromNormalizedFilePath filePath)
130− onFileModified compilerH filePath Nothing
131− modifyFilesOfInterest compilerH (S.delete filePath)
132−
133−-- | Manages the file store (caching compilation results and unsaved content).
134−onFileModified
135− :: IdeState
136− -> NormalizedFilePath
137− -> Maybe T.Text
138− -> IO ()
139−onFileModified service fp mbContents = do
140− logDebug (ideLogger service) $ "File modified " <> T.pack (show fp)
141− setBufferModified service fp mbContents
14232
143−------------------------------------------------------------------------
144−-- Server execution
145−------------------------------------------------------------------------
14633
14734runLanguageServer
148− :: Logger
149− -> ((FromServerMessage -> IO ()) -> VFSHandle -> IO IdeState)
35+ :: ((FromServerMessage -> IO ()) -> VFSHandle -> IO IdeState)
15036 -> IO ()
151−runLanguageServer loggerH getIdeState = do
152− let getHandlers lspFuncs = do
153− compilerH <- getIdeState (sendFunc lspFuncs) (makeLSPVFSHandle lspFuncs)
154− pure $ Handlers (handleRequest loggerH compilerH) (handleNotification lspFuncs loggerH compilerH)
155− liftIO $ runServer loggerH getHandlers
37+runLanguageServer getIdeState = do
38+ -- Move stdout to another file descriptor and duplicate stderr
39+ -- to stdout. This guards against stray prints from corrupting the JSON-RPC
40+ -- message stream.
41+ newStdout <- hDuplicate stdout
42+ stderr `hDuplicateTo` stdout
43+
44+ -- Print out a single space to assert that the above redirection works.
45+ -- This is interleaved with the logger, hence we just print a space here in
46+ -- order not to mess up the output too much. Verified that this breaks
47+ -- the language server tests without the redirection.
48+ putStr " " >> hFlush stdout
49+
50+ -- Send everything over a channel, since you need to wait until after initialise before
51+ -- LspFuncs is available
52+ clientMsgChan :: Chan Message <- newChan
53+
54+ -- These barriers are signaled when the threads reading from these chans exit.
55+ -- This should not happen but if it does, we will make sure that the whole server
56+ -- dies and can be restarted instead of losing threads silently.
57+ clientMsgBarrier <- newBarrier
58+
59+ let withResponse wrap f = Just $ \r -> writeChan clientMsgChan $ Response r wrap f
60+ let withNotification f = Just $ \r -> writeChan clientMsgChan $ Notification r f
61+ let runHandler = WithMessage{withResponse, withNotification}
62+ handlers <- mergeHandlers [setHandlersDefinition, setHandlersHover, setHandlersNotifications, setHandlersIgnore] runHandler def
63+
64+ void $ waitAnyCancel =<< traverse async
65+ [ void $ LSP.runWithHandles
66+ stdin
67+ newStdout
68+ ( const $ Right ()
69+ , handleInit (signalBarrier clientMsgBarrier ()) clientMsgChan
70+ )
71+ handlers
72+ options
73+ Nothing
74+ , void $ waitBarrier clientMsgBarrier
75+ ]
76+ where
77+ handleInit :: IO () -> Chan Message -> LSP.LspFuncs () -> IO (Maybe err)
78+ handleInit exitClientMsg clientMsgChan lspFuncs@LSP.LspFuncs{..} = do
79+ ide <- getIdeState sendFunc (makeLSPVFSHandle lspFuncs)
80+ _ <- flip forkFinally (const exitClientMsg) $ forever $ do
81+ msg <- readChan clientMsgChan
82+ case msg of
83+ Notification NotificationMessage{_params} act -> act ide _params
84+ Response RequestMessage{_id, _params} wrap act -> do
85+ res <- act ide _params
86+ sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Just res) Nothing
87+ pure Nothing
88+
89+
90+-- | Things that get sent to us, but we don't deal with.
91+-- Set them to avoid a warning in VS Code output.
92+setHandlersIgnore :: WithMessage -> LSP.Handlers -> IO LSP.Handlers
93+setHandlersIgnore _ x = return x
94+ {LSP.cancelNotificationHandler = none
95+ ,LSP.initializedHandler = none
96+ ,LSP.codeLensHandler = none -- FIXME: Stop saying we support it in 'options'
97+ }
98+ where none = Just $ const $ return ()
99+
100+
101+mergeHandlers :: [WithMessage -> LSP.Handlers -> IO LSP.Handlers] -> WithMessage -> LSP.Handlers -> IO LSP.Handlers
102+mergeHandlers = foldl f (\_ a -> return a)
103+ where f x1 x2 r a = x1 r a >>= x2 r
104+
105+
106+-- | A message that we need to deal with - the pieces are split up with existentials to gain additional type safety
107+-- and defer precise processing until later (allows us to keep at a higher level of abstraction slightly longer)
108+data Message
109+ = forall m req resp . Response (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (IdeState -> req -> IO resp)
110+ | forall m req . Notification (NotificationMessage m req) (IdeState -> req -> IO ())
111+
112+
113+options :: LSP.Options
114+options = def
115+ { LSP.textDocumentSync = Just TextDocumentSyncOptions
116+ { _openClose = Just True
117+ , _change = Just TdSyncIncremental
118+ , _willSave = Nothing
119+ , _willSaveWaitUntil = Nothing
120+ , _save = Just $ SaveOptions $ Just False
121+ }
122+ , LSP.codeLensProvider = Just $ CodeLensOptions $ Just False
123+ }