From d431cfaf00baea653194602942c2ce81c16960f4 Mon Sep 17 00:00:00 2001 From: Neil Mitchell <35463327+neil-da@users.noreply.github.com> Date: Wed, 26 Jun 2019 11:01:42 +0100 Subject: [PATCH] Move the DAML language server to be based on the hie-core server (#1880) * Move the DAML language server to be based on the hie-core language server, supply extensions around the outside * HLint --- .../daml-ghc/language-server/BUILD.bazel | 1 + .../src/DA/Service/Daml/LanguageServer.hs | 177 +++++------------- .../Service/Daml/LanguageServer/CodeLens.hs | 18 +- .../daml-tools/da-hs-daml-cli/DA/Cli/Damlc.hs | 2 +- 4 files changed, 64 insertions(+), 134 deletions(-) diff --git a/daml-foundations/daml-ghc/language-server/BUILD.bazel b/daml-foundations/daml-ghc/language-server/BUILD.bazel index 254dbf2d99ee..31016ce8c2b3 100644 --- a/daml-foundations/daml-ghc/language-server/BUILD.bazel +++ b/daml-foundations/daml-ghc/language-server/BUILD.bazel @@ -14,6 +14,7 @@ da_haskell_library( "async", "base", "containers", + "data-default", "extra", "haskell-lsp", "haskell-lsp-types", diff --git a/daml-foundations/daml-ghc/language-server/src/DA/Service/Daml/LanguageServer.hs b/daml-foundations/daml-ghc/language-server/src/DA/Service/Daml/LanguageServer.hs index 7059a591643c..35425a552a2d 100644 --- a/daml-foundations/daml-ghc/language-server/src/DA/Service/Daml/LanguageServer.hs +++ b/daml-foundations/daml-ghc/language-server/src/DA/Service/Daml/LanguageServer.hs @@ -12,15 +12,14 @@ module DA.Service.Daml.LanguageServer import Development.IDE.LSP.Protocol import Development.IDE.LSP.Server +import qualified Development.IDE.LSP.LanguageServer as LS +import Control.Monad.Extra +import Data.Default -import Control.Monad.IO.Class import qualified DA.Service.Daml.LanguageServer.CodeLens as LS.CodeLens -import qualified Development.IDE.LSP.Definition as LS.Definition -import qualified Development.IDE.LSP.Hover as LS.Hover import Development.IDE.Types.Logger import qualified Data.Aeson as Aeson -import qualified Data.Rope.UTF16 as Rope import qualified Data.Set as S import qualified Data.Text as T @@ -28,15 +27,12 @@ import Development.IDE.Core.FileStore import Development.IDE.Core.Rules import Development.IDE.Core.Rules.Daml import Development.IDE.Core.Service.Daml -import Development.IDE.Types.Location import qualified Network.URI as URI -import qualified System.Exit - -import Language.Haskell.LSP.Core (LspFuncs(..)) import Language.Haskell.LSP.Messages -import Language.Haskell.LSP.VFS +import qualified Language.Haskell.LSP.Core as LSP + textShow :: Show a => a -> T.Text textShow = T.pack . show @@ -45,129 +41,54 @@ textShow = T.pack . show -- Request handlers ------------------------------------------------------------------------ -handleRequest - :: Logger - -> IdeState - -> (forall resp. resp -> ResponseMessage resp) - -> (ErrorCode -> ResponseMessage ()) - -> ServerRequest - -> IO FromServerMessage -handleRequest logger compilerH makeResponse makeErrorResponse = \case - Shutdown -> do - logInfo logger "Shutdown request received, terminating." - System.Exit.exitSuccess - - KeepAlive -> pure $ RspCustomServer $ makeResponse Aeson.Null - - Definition params -> RspDefinition . makeResponse <$> LS.Definition.gotoDefinition compilerH params - Hover params -> RspHover . makeResponse <$> LS.Hover.onHover compilerH params - CodeLens params -> RspCodeLens . makeResponse <$> LS.CodeLens.handle logger compilerH params - - req -> do - logWarning logger ("Method not found" <> T.pack (show req)) - pure $ RspError $ makeErrorResponse MethodNotFound - - -handleNotification :: LspFuncs () -> Logger -> IdeState -> ServerNotification -> IO () -handleNotification lspFuncs logger compilerH = \case - - DidOpenTextDocument (DidOpenTextDocumentParams item) -> do - case URI.parseURI $ T.unpack $ getUri $ _uri (item :: TextDocumentItem) of - Just uri - | URI.uriScheme uri == "file:" - -> handleDidOpenFile item - - | URI.uriScheme uri == "daml:" - -> handleDidOpenVirtualResource uri - - | otherwise - -> logWarning logger $ "Unknown scheme in URI: " - <> textShow uri - - _ -> logSeriousError logger $ "Invalid URI in DidOpenTextDocument: " - <> textShow (_uri (item :: TextDocumentItem)) - - DidChangeTextDocument (DidChangeTextDocumentParams docId _) -> do - let uri = _uri (docId :: VersionedTextDocumentIdentifier) - - case uriToFilePath' uri of - Just (toNormalizedFilePath -> filePath) -> do - mbVirtual <- getVirtualFileFunc lspFuncs $ toNormalizedUri uri - let contents = maybe "" (Rope.toText . (_text :: VirtualFile -> Rope.Rope)) mbVirtual - onFileModified compilerH filePath (Just contents) - logInfo logger - $ "Updated text document: " <> textShow (fromNormalizedFilePath filePath) - - Nothing -> - logSeriousError logger - $ "Invalid file path: " <> textShow (_uri (docId :: VersionedTextDocumentIdentifier)) - - DidCloseTextDocument (DidCloseTextDocumentParams (TextDocumentIdentifier uri)) -> - case URI.parseURI $ T.unpack $ getUri uri of - Just uri' - | URI.uriScheme uri' == "file:" -> do - Just fp <- pure $ toNormalizedFilePath <$> uriToFilePath' uri - handleDidCloseFile fp - | URI.uriScheme uri' == "daml:" -> handleDidCloseVirtualResource uri' - | otherwise -> logWarning logger $ "Unknown scheme in URI: " <> textShow uri - - _ -> logSeriousError logger - $ "Invalid URI in DidCloseTextDocument: " - <> textShow uri - - DidSaveTextDocument _params -> - pure () - - UnknownNotification _method _params -> return () - where - -- Note that the state changes here are not atomic. - -- When we have parallel compilation we could manage the state - -- changes in STM so that we can atomically change the state. - -- Internally it should be done via the IO oracle. See PROD-2808. - handleDidOpenFile (TextDocumentItem uri _ _ contents) = do - Just filePath <- pure $ toNormalizedFilePath <$> uriToFilePath' uri - onFileModified compilerH filePath (Just contents) - modifyFilesOfInterest compilerH (S.insert filePath) - logInfo logger $ "Opened text document: " <> textShow filePath - - handleDidOpenVirtualResource uri = do - case uriToVirtualResource uri of - Nothing -> logWarning logger $ "Failed to parse virtual resource URI: " <> textShow uri - Just vr -> do - logInfo logger $ "Opened virtual resource: " <> textShow vr - modifyOpenVirtualResources compilerH (S.insert vr) - - handleDidCloseFile filePath = do - logInfo logger $ "Closed text document: " <> textShow (fromNormalizedFilePath filePath) - onFileModified compilerH filePath Nothing - modifyFilesOfInterest compilerH (S.delete filePath) - - handleDidCloseVirtualResource uri = do - logInfo logger $ "Closed virtual resource: " <> textShow uri - case uriToVirtualResource uri of - Nothing -> logWarning logger "Failed to parse virtual resource URI!" - Just vr -> modifyOpenVirtualResources compilerH (S.delete vr) - --- | Manages the file store (caching compilation results and unsaved content). -onFileModified - :: IdeState - -> NormalizedFilePath - -> Maybe T.Text - -> IO () -onFileModified service fp mbContents = do - logDebug (ideLogger service) $ "File modified " <> T.pack (show fp) - setBufferModified service fp mbContents +setHandlersKeepAlive :: PartialHandlers +setHandlersKeepAlive = PartialHandlers $ \WithMessage{..} x -> return x + {LSP.customRequestHandler = Just $ \msg@RequestMessage{_method} -> + case _method of + CustomClientMethod "daml/keepAlive" -> + maybe (return ()) ($ msg) $ + withResponse RspCustomServer (\_ _ -> return Aeson.Null) + _ -> whenJust (LSP.customRequestHandler x) ($ msg) + } + +setHandlersVirtualResource :: PartialHandlers +setHandlersVirtualResource = PartialHandlers $ \WithMessage{..} x -> return x + {LSP.didOpenTextDocumentNotificationHandler = withNotification (LSP.didOpenTextDocumentNotificationHandler x) $ + \ide (DidOpenTextDocumentParams TextDocumentItem{_uri}) -> + withUriDaml _uri $ \vr -> do + logInfo (ideLogger ide) $ "Opened virtual resource NEIL: " <> textShow vr + modifyOpenVirtualResources ide (S.insert vr) + + ,LSP.didCloseTextDocumentNotificationHandler = withNotification (LSP.didCloseTextDocumentNotificationHandler x) $ + \ide (DidCloseTextDocumentParams TextDocumentIdentifier{_uri}) -> do + withUriDaml _uri $ \vr -> do + logInfo (ideLogger ide) $ "Closed virtual resource: " <> textShow vr + modifyOpenVirtualResources ide (S.delete vr) + } + + +withUriDaml :: Uri -> (VirtualResource -> IO ()) -> IO () +withUriDaml x f + | Just uri <- URI.parseURI $ T.unpack $ getUri x + , URI.uriScheme uri == "daml:" + , Just vr <- uriToVirtualResource uri + = f vr +withUriDaml _ _ = return () + ------------------------------------------------------------------------ -- Server execution ------------------------------------------------------------------------ runLanguageServer - :: Logger - -> ((FromServerMessage -> IO ()) -> VFSHandle -> IO IdeState) + :: ((FromServerMessage -> IO ()) -> VFSHandle -> IO IdeState) -> IO () -runLanguageServer logger getIdeState = do - let getHandlers lspFuncs = do - compilerH <- getIdeState (sendFunc lspFuncs) (makeLSPVFSHandle lspFuncs) - pure $ Handlers (handleRequest logger compilerH) (handleNotification lspFuncs logger compilerH) - liftIO $ runServer logger getHandlers +runLanguageServer getIdeState = do + let handlers = setHandlersKeepAlive <> setHandlersVirtualResource <> LS.CodeLens.setHandlersCodeLens + LS.runLanguageServer options handlers getIdeState + + +options :: LSP.Options +options = def + { LSP.codeLensProvider = Just $ CodeLensOptions $ Just False + } diff --git a/daml-foundations/daml-ghc/language-server/src/DA/Service/Daml/LanguageServer/CodeLens.hs b/daml-foundations/daml-ghc/language-server/src/DA/Service/Daml/LanguageServer/CodeLens.hs index f15684b128b2..e2fa8c493dbf 100644 --- a/daml-foundations/daml-ghc/language-server/src/DA/Service/Daml/LanguageServer/CodeLens.hs +++ b/daml-foundations/daml-ghc/language-server/src/DA/Service/Daml/LanguageServer/CodeLens.hs @@ -6,6 +6,7 @@ -- | Gather code lenses like scenario execution for a DAML file. module DA.Service.Daml.LanguageServer.CodeLens ( handle + , setHandlersCodeLens ) where import Language.Haskell.LSP.Types @@ -15,20 +16,22 @@ import Data.Foldable import Data.Maybe import qualified Data.Text as T import qualified DA.Service.Daml.Compiler.Impl.Handle as Compiler +import Development.IDE.LSP.Server +import qualified Language.Haskell.LSP.Core as LSP +import Language.Haskell.LSP.Messages import Development.IDE.Types.Logger import Development.IDE.Types.Location -- | Gather code lenses like scenario execution for a DAML file. handle - :: Logger - -> Compiler.IdeState + :: Compiler.IdeState -> CodeLensParams -> IO (List CodeLens) -handle logger compilerH (CodeLensParams (TextDocumentIdentifier uri)) = do +handle ide (CodeLensParams (TextDocumentIdentifier uri)) = do mbResult <- case uriToFilePath' uri of Just (toNormalizedFilePath -> filePath) -> do - logInfo logger $ "CodeLens request for file: " <> T.pack (fromNormalizedFilePath filePath) - vrs <- Compiler.getAssociatedVirtualResources compilerH filePath + logInfo (ideLogger ide) $ "CodeLens request for file: " <> T.pack (fromNormalizedFilePath filePath) + vrs <- Compiler.getAssociatedVirtualResources ide filePath pure $ mapMaybe virtualResourceToCodeLens vrs Nothing -> pure [] @@ -49,3 +52,8 @@ virtualResourceToCodeLens (range, title, vr) = , Aeson.String $ Compiler.virtualResourceToUri vr]) , _xdata = Nothing } + +setHandlersCodeLens :: PartialHandlers +setHandlersCodeLens = PartialHandlers $ \WithMessage{..} x -> return x{ + LSP.codeLensHandler = withResponse RspCodeLens handle + } diff --git a/daml-foundations/daml-tools/da-hs-daml-cli/DA/Cli/Damlc.hs b/daml-foundations/daml-tools/da-hs-daml-cli/DA/Cli/Damlc.hs index 62daac3b7764..5e31fdd38585 100644 --- a/daml-foundations/daml-tools/da-hs-daml-cli/DA/Cli/Damlc.hs +++ b/daml-foundations/daml-tools/da-hs-daml-cli/DA/Cli/Damlc.hs @@ -268,7 +268,7 @@ execIde telemetry (Debug debug) enableScenarioService = NS.withSocketsDo $ do execInit LF.versionDefault (ProjectOpts Nothing (ProjectCheck "" False)) (InitPkgDb True) sdkVersion <- getSdkVersion `catchIO` const (pure "Unknown (not started via the assistant)") Logger.logInfo loggerH (T.pack $ "SDK version: " <> sdkVersion) - Daml.LanguageServer.runLanguageServer (toIdeLogger loggerH) + Daml.LanguageServer.runLanguageServer (getIdeState opts mbScenarioService loggerH) execCompile :: FilePath -> FilePath -> Compiler.Options -> Command