Skip to content

Commit

Permalink
Move the DAML language server to be based on the hie-core server (dig…
Browse files Browse the repository at this point in the history 
…ital-asset#1880)

* Move the DAML language server to be based on the hie-core language server, supply extensions around the outside

* HLint
  • Loading branch information
@neil-da
neil-da authored Jun 26, 2019
1 parent 7878120 commit d431cfa
Show file tree
Hide file tree
Showing 4 changed files with 64 additions and 134 deletions.
1 change: 1 addition & 0 deletions daml-foundations/daml-ghc/language-server/BUILD.bazel
View file
Original file line number Diff line number Diff line change
Expand Up @@ -14,6 +14,7 @@ da_haskell_library(
"async",
"base",
"containers",
"data-default",
"extra",
"haskell-lsp",
"haskell-lsp-types",
Expand Down
177 changes: 49 additions & 128 deletions daml-foundations/daml-ghc/language-server/src/DA/Service/Daml/LanguageServer.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -12,31 +12,27 @@ 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

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
Expand All @@ -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
}
18 changes: 13 additions & 5 deletions daml-foundations/daml-ghc/language-server/src/DA/Service/Daml/LanguageServer/CodeLens.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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 []

Expand All @@ -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
}
2 changes: 1 addition & 1 deletion daml-foundations/daml-tools/da-hs-daml-cli/DA/Cli/Damlc.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down

0 comments on commit d431cfa

Please sign in to comment.