git.iko.soy/ghcide
on 210de4e help sign in
ghcide/src/Development/IDE/LSP/LanguageServer.hs
154 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 DuplicateRecordFields #-}
5{-# LANGUAGE OverloadedStrings #-}
6{-# LANGUAGE RankNTypes #-}
8-- WARNING: A copy of DA.Service.Daml.LanguageServer, try to keep them in sync
9-- This version removes the daml: handling
10module Development.IDE.LSP.LanguageServer
11 ( runLanguageServer
12 ) where
14import Development.IDE.LSP.Protocol
15import Development.IDE.LSP.Server
17import Control.Monad.IO.Class
18import qualified Development.IDE.LSP.Definition as LS.Definition
19import qualified Development.IDE.LSP.Hover as LS.Hover
20import qualified Development.IDE.Logger as Logger
21import Development.IDE.State.Service
23import qualified Data.Aeson as Aeson
24import qualified Data.Rope.UTF16 as Rope
25import qualified Data.Set as S
26import qualified Data.Text as T
28import Development.IDE.State.FileStore
29import Development.IDE.Types.Diagnostics
31import qualified Network.URI as URI
33import qualified System.Exit
35import Language.Haskell.LSP.Core (LspFuncs(..))
36import Language.Haskell.LSP.Messages
37import Language.Haskell.LSP.VFS
39textShow :: Show a => a -> T.Text
40textShow = T.pack . show
42------------------------------------------------------------------------
43-- Request handlers
44------------------------------------------------------------------------
46handleRequest
47 :: Logger.Handle
48 -> IdeState
49 -> (forall resp. resp -> ResponseMessage resp)
50 -> (ErrorCode -> ResponseMessage ())
51 -> ServerRequest
52 -> IO FromServerMessage
53handleRequest loggerH compilerH makeResponse makeErrorResponse = \case
54 Shutdown -> do
55 Logger.logInfo loggerH "Shutdown request received, terminating."
56 System.Exit.exitSuccess
58 KeepAlive -> pure $ RspCustomServer $ makeResponse Aeson.Null
60 Definition params -> RspDefinition . makeResponse <$> LS.Definition.handle loggerH compilerH params
61 Hover params -> RspHover . makeResponse <$> LS.Hover.handle loggerH compilerH params
62 CodeLens _params -> pure $ RspCodeLens $ makeResponse mempty
64 req -> do
65 Logger.logWarning loggerH ("Method not found" <> T.pack (show req))
66 pure $ RspError $ makeErrorResponse MethodNotFound
69handleNotification :: LspFuncs () -> Logger.Handle -> IdeState -> ServerNotification -> IO ()
70handleNotification lspFuncs loggerH compilerH = \case
72 DidOpenTextDocument (DidOpenTextDocumentParams item) -> do
73 case URI.parseURI $ T.unpack $ getUri $ _uri (item :: TextDocumentItem) of
74 Just uri
75 | URI.uriScheme uri == "file:"
76 -> handleDidOpenFile item
78 | otherwise
79 -> Logger.logWarning loggerH $ "Unknown scheme in URI: "
80 <> textShow uri
82 _ -> Logger.logSeriousError loggerH $ "Invalid URI in DidOpenTextDocument: "
83 <> textShow (_uri (item :: TextDocumentItem))
85 DidChangeTextDocument (DidChangeTextDocumentParams docId _) -> do
86 let uri = _uri (docId :: VersionedTextDocumentIdentifier)
88 case uriToFilePath' uri of
89 Just (toNormalizedFilePath -> filePath) -> do
90 mbVirtual <- getVirtualFileFunc lspFuncs $ toNormalizedUri uri
91 let contents = maybe "" (Rope.toText . (_text :: VirtualFile -> Rope.Rope)) mbVirtual
92 onFileModified compilerH filePath (Just contents)
93 Logger.logInfo loggerH
94 $ "Updated text document: " <> textShow (fromNormalizedFilePath filePath)
96 Nothing ->
97 Logger.logSeriousError loggerH
98 $ "Invalid file path: " <> textShow (_uri (docId :: VersionedTextDocumentIdentifier))
100 DidCloseTextDocument (DidCloseTextDocumentParams (TextDocumentIdentifier uri)) ->
101 case URI.parseURI $ T.unpack $ getUri uri of
102 Just uri'
103 | URI.uriScheme uri' == "file:" -> do
104 Just fp <- pure $ toNormalizedFilePath <$> uriToFilePath' uri
105 handleDidCloseFile fp
106 | otherwise -> Logger.logWarning loggerH $ "Unknown scheme in URI: " <> textShow uri
108 _ -> Logger.logSeriousError loggerH
109 $ "Invalid URI in DidCloseTextDocument: "
110 <> textShow uri
112 DidSaveTextDocument _params ->
113 pure ()
115 UnknownNotification _method _params -> return ()
116 where
117 -- Note that the state changes here are not atomic.
118 -- When we have parallel compilation we could manage the state
119 -- changes in STM so that we can atomically change the state.
120 -- Internally it should be done via the IO oracle. See PROD-2808.
121 handleDidOpenFile (TextDocumentItem uri _ _ contents) = do
122 Just filePath <- pure $ toNormalizedFilePath <$> uriToFilePath' uri
123 onFileModified compilerH filePath (Just contents)
124 modifyFilesOfInterest compilerH (S.insert filePath)
125 Logger.logInfo loggerH $ "Opened text document: " <> textShow filePath
127 handleDidCloseFile filePath = do
128 Logger.logInfo loggerH $ "Closed text document: " <> textShow (fromNormalizedFilePath filePath)
129 onFileModified compilerH filePath Nothing
130 modifyFilesOfInterest compilerH (S.delete filePath)
132-- | Manages the file store (caching compilation results and unsaved content).
133onFileModified
134 :: IdeState
135 -> NormalizedFilePath
136 -> Maybe T.Text
137 -> IO ()
138onFileModified service fp mbContents = do
139 logDebug service $ "File modified " <> T.pack (show fp)
140 setBufferModified service fp mbContents
142------------------------------------------------------------------------
143-- Server execution
144------------------------------------------------------------------------
146runLanguageServer
147 :: Logger.Handle
148 -> ((FromServerMessage -> IO ()) -> VFSHandle -> IO IdeState)
149 -> IO ()
150runLanguageServer loggerH getIdeState = do
151 let getHandlers lspFuncs = do
152 compilerH <- getIdeState (sendFunc lspFuncs) (makeLSPVFSHandle lspFuncs)
153 pure $ Handlers (handleRequest loggerH compilerH) (handleNotification lspFuncs loggerH compilerH)
154 liftIO $ runServer loggerH getHandlers