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