From 124a4d47dabb4831d9ac91a8b6e2a90a5f3798bf Mon Sep 17 00:00:00 2001 From: Neil Mitchell <35463327+neil-da@users.noreply.github.com> Date: Wed, 26 Jun 2019 09:04:10 +0100 Subject: [PATCH] Make the hie-core server retargetable (#1873) * Move mergeHandlers into Server * Make partial handlers a proper newtype * Pass the options in to runLanguageServer * Take in user handlers * Remove the code lens handler since we don't advertise it * Add setSomethingModified, rather than faking it for the LSP VFS * Rewrite the LSP notifications * Improve the display of info messages around openning and modifying text documents * Make sure stdout and stderr don't have buffering, so we see their output immediately * Handle exit properly * Make notifications forward on to their previous values * Remove the exit handler, HIE already has a good default for it * Add comments on FileStore --- BUILD.bazel | 1 + hie-core.cabal | 1 + src/Development/IDE/Core/FileStore.hs | 30 ++++++-- src/Development/IDE/LSP/Definition.hs | 4 +- src/Development/IDE/LSP/Hover.hs | 4 +- src/Development/IDE/LSP/LanguageServer.hs | 48 ++++++------ src/Development/IDE/LSP/Notifications.hs | 94 ++++++----------------- src/Development/IDE/LSP/Server.hs | 21 ++++- test/Demo.hs | 3 +- 9 files changed, 95 insertions(+), 111 deletions(-) diff --git a/BUILD.bazel b/BUILD.bazel index 7a777f3f..a9c247fa 100644 --- a/BUILD.bazel +++ b/BUILD.bazel @@ -71,6 +71,7 @@ da_haskell_binary( hazel_deps = [ "base", "containers", + "data-default", "directory", "extra", "ghc-paths", diff --git a/hie-core.cabal b/hie-core.cabal index 425a72cd..42da17f2 100644 --- a/hie-core.cabal +++ b/hie-core.cabal @@ -111,6 +111,7 @@ executable hie-core directory, hie-bios, shake, + data-default, ghc-paths, ghc, extra, diff --git a/src/Development/IDE/Core/FileStore.hs b/src/Development/IDE/Core/FileStore.hs index 88308464..62d4973c 100644 --- a/src/Development/IDE/Core/FileStore.hs +++ b/src/Development/IDE/Core/FileStore.hs @@ -6,6 +6,7 @@ module Development.IDE.Core.FileStore( getFileExists, getFileContents, setBufferModified, + setSomethingModified, fileStoreRules, VFSHandle, makeVFSHandle, @@ -44,7 +45,10 @@ import Language.Haskell.LSP.VFS -- like `setBufferModified` we abstract over the VFS implementation. data VFSHandle = VFSHandle { getVirtualFile :: NormalizedUri -> IO (Maybe VirtualFile) - , setVirtualFileContents :: NormalizedUri -> Maybe T.Text -> IO () + -- ^ get the contents of a virtual file + , setVirtualFileContents :: Maybe (NormalizedUri -> Maybe T.Text -> IO ()) + -- ^ set a specific file to a value. If Nothing then we are ignoring these + -- signals anyway so can just say something was modified } instance IsIdeGlobal VFSHandle @@ -56,7 +60,7 @@ makeVFSHandle = do { getVirtualFile = \uri -> do (_nextVersion, vfs) <- readVar vfsVar pure $ Map.lookup uri vfs - , setVirtualFileContents = \uri content -> + , setVirtualFileContents = Just $ \uri content -> modifyVar_ vfsVar $ \(nextVersion, vfs) -> pure $ (nextVersion + 1, ) $ case content of Nothing -> Map.delete uri vfs @@ -66,9 +70,8 @@ makeVFSHandle = do makeLSPVFSHandle :: LspFuncs c -> VFSHandle makeLSPVFSHandle lspFuncs = VFSHandle { getVirtualFile = getVirtualFileFunc lspFuncs - , setVirtualFileContents = \_ _ -> pure () - -- ^ Handled internally by haskell-lsp. - } + , setVirtualFileContents = Nothing + } -- | Get the contents of a file, either dirty (if the buffer is modified) or from disk. @@ -158,11 +161,24 @@ fileStoreRules vfs = do getFileExistsRule vfs --- | Notify the compiler service of a modified buffer +-- | Notify the compiler service that a particular file has been modified. +-- Use 'Nothing' to say the file is no longer in the virtual file system +-- but should be sourced from disk, or 'Just' to give its new value. setBufferModified :: IdeState -> NormalizedFilePath -> Maybe T.Text -> IO () setBufferModified state absFile contents = do VFSHandle{..} <- getIdeGlobalState state - setVirtualFileContents (filePathToUri' absFile) contents + whenJust setVirtualFileContents $ \set -> + set (filePathToUri' absFile) contents + void $ shakeRun state [] (const $ pure ()) + +-- | Note that some buffer somewhere has been modified, but don't say what. +-- Only valid if the virtual file system was initialised by LSP, as that +-- independently tracks which files are modified. +setSomethingModified :: IdeState -> IO () +setSomethingModified state = do + VFSHandle{..} <- getIdeGlobalState state + when (isJust setVirtualFileContents) $ + fail "setSomethingModified can't be called on this type of VFSHandle" void $ shakeRun state [] (const $ pure ()) diff --git a/src/Development/IDE/LSP/Definition.hs b/src/Development/IDE/LSP/Definition.hs index d0192424..004ed42d 100644 --- a/src/Development/IDE/LSP/Definition.hs +++ b/src/Development/IDE/LSP/Definition.hs @@ -39,7 +39,7 @@ gotoDefinition ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos) Just loc -> SingleLoc loc -setHandlersDefinition :: WithMessage -> LSP.Handlers -> IO LSP.Handlers -setHandlersDefinition WithMessage{..} x = return x{ +setHandlersDefinition :: PartialHandlers +setHandlersDefinition = PartialHandlers $ \WithMessage{..} x -> return x{ LSP.definitionHandler = withResponse RspDefinition gotoDefinition } diff --git a/src/Development/IDE/LSP/Hover.hs b/src/Development/IDE/LSP/Hover.hs index 0b283cdf..d0e7ab79 100644 --- a/src/Development/IDE/LSP/Hover.hs +++ b/src/Development/IDE/LSP/Hover.hs @@ -43,7 +43,7 @@ onHover ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos) = do Nothing -> pure Nothing -setHandlersHover :: WithMessage -> LSP.Handlers -> IO LSP.Handlers -setHandlersHover WithMessage{..} x = return x{ +setHandlersHover :: PartialHandlers +setHandlersHover = PartialHandlers $ \WithMessage{..} x -> return x{ LSP.hoverHandler = withResponse RspHover onHover } diff --git a/src/Development/IDE/LSP/LanguageServer.hs b/src/Development/IDE/LSP/LanguageServer.hs index 66533065..69f1f2be 100644 --- a/src/Development/IDE/LSP/LanguageServer.hs +++ b/src/Development/IDE/LSP/LanguageServer.hs @@ -18,9 +18,10 @@ import Control.Concurrent.Chan import Control.Concurrent.Extra import Control.Concurrent.Async import Data.Default +import Data.Maybe import GHC.IO.Handle (hDuplicate, hDuplicateTo) import System.IO -import Control.Monad +import Control.Monad.Extra import Development.IDE.LSP.Definition import Development.IDE.LSP.Hover @@ -32,14 +33,18 @@ import Language.Haskell.LSP.Messages runLanguageServer - :: ((FromServerMessage -> IO ()) -> VFSHandle -> IO IdeState) + :: LSP.Options + -> PartialHandlers + -> ((FromServerMessage -> IO ()) -> VFSHandle -> IO IdeState) -> IO () -runLanguageServer getIdeState = do +runLanguageServer options userHandlers getIdeState = do -- Move stdout to another file descriptor and duplicate stderr -- to stdout. This guards against stray prints from corrupting the JSON-RPC -- message stream. newStdout <- hDuplicate stdout stderr `hDuplicateTo` stdout + hSetBuffering stderr NoBuffering + hSetBuffering stdout NoBuffering -- Print out a single space to assert that the above redirection works. -- This is interleaved with the logger, hence we just print a space here in @@ -57,9 +62,13 @@ runLanguageServer getIdeState = do clientMsgBarrier <- newBarrier let withResponse wrap f = Just $ \r -> writeChan clientMsgChan $ Response r wrap f - let withNotification f = Just $ \r -> writeChan clientMsgChan $ Notification r f - let runHandler = WithMessage{withResponse, withNotification} - handlers <- mergeHandlers [setHandlersDefinition, setHandlersHover, setHandlersNotifications, setHandlersIgnore] runHandler def + let withNotification old f = Just $ \r -> writeChan clientMsgChan $ Notification r (\ide x -> f ide x >> whenJust old ($ r)) + let PartialHandlers parts = + setHandlersIgnore <> -- least important + setHandlersDefinition <> setHandlersHover <> -- useful features someone may override + userHandlers <> + setHandlersNotifications -- absolutely critical, join them with user notifications + handlers <- parts WithMessage{withResponse, withNotification} def void $ waitAnyCancel =<< traverse async [ void $ LSP.runWithHandles @@ -69,7 +78,7 @@ runLanguageServer getIdeState = do , handleInit (signalBarrier clientMsgBarrier ()) clientMsgChan ) handlers - options + (modifyOptions options) Nothing , void $ waitBarrier clientMsgBarrier ] @@ -89,20 +98,14 @@ runLanguageServer getIdeState = do -- | Things that get sent to us, but we don't deal with. -- Set them to avoid a warning in VS Code output. -setHandlersIgnore :: WithMessage -> LSP.Handlers -> IO LSP.Handlers -setHandlersIgnore _ x = return x +setHandlersIgnore :: PartialHandlers +setHandlersIgnore = PartialHandlers $ \_ x -> return x {LSP.cancelNotificationHandler = none ,LSP.initializedHandler = none - ,LSP.codeLensHandler = none -- FIXME: Stop saying we support it in 'options' } where none = Just $ const $ return () -mergeHandlers :: [WithMessage -> LSP.Handlers -> IO LSP.Handlers] -> WithMessage -> LSP.Handlers -> IO LSP.Handlers -mergeHandlers = foldl f (\_ a -> return a) - where f x1 x2 r a = x1 r a >>= x2 r - - -- | A message that we need to deal with - the pieces are split up with existentials to gain additional type safety -- and defer precise processing until later (allows us to keep at a higher level of abstraction slightly longer) data Message @@ -110,14 +113,7 @@ data Message | forall m req . Notification (NotificationMessage m req) (IdeState -> req -> IO ()) -options :: LSP.Options -options = def - { LSP.textDocumentSync = Just TextDocumentSyncOptions - { _openClose = Just True - , _change = Just TdSyncIncremental - , _willSave = Nothing - , _willSaveWaitUntil = Nothing - , _save = Just $ SaveOptions $ Just False - } - , LSP.codeLensProvider = Just $ CodeLensOptions $ Just False - } +modifyOptions :: LSP.Options -> LSP.Options +modifyOptions x = x{LSP.textDocumentSync = Just orig{_openClose=Just True, _change=Just TdSyncIncremental}} + where orig = fromMaybe tdsDefault $ LSP.textDocumentSync x + tdsDefault = TextDocumentSyncOptions Nothing Nothing Nothing Nothing Nothing diff --git a/src/Development/IDE/LSP/Notifications.hs b/src/Development/IDE/LSP/Notifications.hs index e4d36ade..be872abe 100644 --- a/src/Development/IDE/LSP/Notifications.hs +++ b/src/Development/IDE/LSP/Notifications.hs @@ -12,89 +12,41 @@ module Development.IDE.LSP.Notifications import Development.IDE.LSP.Protocol import Development.IDE.LSP.Server hiding (runServer) import qualified Language.Haskell.LSP.Core as LSP +import qualified Language.Haskell.LSP.Types as LSP import Development.IDE.Types.Logger import Development.IDE.Core.Service import Development.IDE.Types.Location import qualified Data.Set as S -import qualified Data.Text as T import Development.IDE.Core.FileStore import Development.IDE.Core.OfInterest -import qualified Network.URI as URI +whenUriFile :: IdeState -> Uri -> (NormalizedFilePath -> IO ()) -> IO () +whenUriFile ide uri act = case LSP.uriToFilePath uri of + Just file -> act $ toNormalizedFilePath file + Nothing -> logWarning (ideLogger ide) $ "Unknown scheme in URI: " <> getUri uri -textShow :: Show a => a -> T.Text -textShow = T.pack . show +setHandlersNotifications :: PartialHandlers +setHandlersNotifications = PartialHandlers $ \WithMessage{..} x -> return x + {LSP.didOpenTextDocumentNotificationHandler = withNotification (LSP.didOpenTextDocumentNotificationHandler x) $ + \ide (DidOpenTextDocumentParams TextDocumentItem{_uri}) -> do + setSomethingModified ide + whenUriFile ide _uri $ \file -> + modifyFilesOfInterest ide (S.insert file) + logInfo (ideLogger ide) $ "Opened text document: " <> getUri _uri + ,LSP.didChangeTextDocumentNotificationHandler = withNotification (LSP.didChangeTextDocumentNotificationHandler x) $ + \ide (DidChangeTextDocumentParams VersionedTextDocumentIdentifier{_uri} _) -> do + setSomethingModified ide + logInfo (ideLogger ide) $ "Modified text document: " <> getUri _uri -setHandlersNotifications :: WithMessage -> LSP.Handlers -> IO LSP.Handlers -setHandlersNotifications WithMessage{..} x = return x{ - LSP.didOpenTextDocumentNotificationHandler = withNotification $ \ide (DidOpenTextDocumentParams item) -> do - case URI.parseURI $ T.unpack $ getUri $ _uri (item :: TextDocumentItem) of - Just uri - | URI.uriScheme uri == "file:" - -> handleDidOpenFile ide item - - | otherwise - -> logWarning (ideLogger ide) $ "Unknown scheme in URI: " - <> textShow uri - - _ -> logSeriousError (ideLogger ide) $ "Invalid URI in DidOpenTextDocument: " - <> textShow (_uri (item :: TextDocumentItem)) - - ,LSP.didChangeTextDocumentNotificationHandler = withNotification $ \ide (DidChangeTextDocumentParams docId _) -> do - let uri = _uri (docId :: VersionedTextDocumentIdentifier) - - case uriToFilePath' uri of - Just (toNormalizedFilePath -> filePath) -> do - onFileModified ide filePath - logInfo (ideLogger ide) - $ "Updated text document: " <> textShow (fromNormalizedFilePath filePath) - - Nothing -> - logSeriousError (ideLogger ide) - $ "Invalid file path: " <> textShow (_uri (docId :: VersionedTextDocumentIdentifier)) - - ,LSP.didCloseTextDocumentNotificationHandler = withNotification $ \ide (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 ide fp - | otherwise -> logWarning (ideLogger ide) $ "Unknown scheme in URI: " <> textShow uri - - _ -> logSeriousError (ideLogger ide) - $ "Invalid URI in DidCloseTextDocument: " - <> textShow uri - + ,LSP.didCloseTextDocumentNotificationHandler = withNotification (LSP.didCloseTextDocumentNotificationHandler x) $ + \ide (DidCloseTextDocumentParams TextDocumentIdentifier{_uri}) -> do + setSomethingModified ide + whenUriFile ide _uri $ \file -> + modifyFilesOfInterest ide (S.delete file) + logInfo (ideLogger ide) $ "Closed text document: " <> getUri _uri } - 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 ide (TextDocumentItem uri _ _ _) = do - Just filePath <- pure $ toNormalizedFilePath <$> uriToFilePath' uri - onFileModified ide filePath - modifyFilesOfInterest ide (S.insert filePath) - logInfo (ideLogger ide) $ "Opened text document: " <> textShow filePath - - handleDidCloseFile ide filePath = do - logInfo (ideLogger ide) $ "Closed text document: " <> textShow (fromNormalizedFilePath filePath) - onFileModified ide filePath - modifyFilesOfInterest ide (S.delete filePath) - - --- | Manages the file store (caching compilation results and unsaved content). -onFileModified - :: IdeState - -> NormalizedFilePath - -> IO () -onFileModified service fp = do - logDebug (ideLogger service) $ "File modified " <> T.pack (show fp) - -- if we get here then we must be using the LSP framework, in which case we don't - -- need to bother sending file modifications, other than to force the database to rerun - setBufferModified service fp Nothing diff --git a/src/Development/IDE/LSP/Server.hs b/src/Development/IDE/LSP/Server.hs index 77b8ff62..dfc152e4 100644 --- a/src/Development/IDE/LSP/Server.hs +++ b/src/Development/IDE/LSP/Server.hs @@ -8,6 +8,7 @@ module Development.IDE.LSP.Server ( runServer , Handlers(..) , WithMessage(..) + , PartialHandlers(..) ) where @@ -38,10 +39,26 @@ import Development.IDE.Core.Service data WithMessage = WithMessage - {withResponse :: forall m req resp . (ResponseMessage resp -> LSP.FromServerMessage) -> (IdeState -> req -> IO resp) -> Maybe (LSP.Handler (RequestMessage m req resp)) - ,withNotification :: forall m req . (IdeState -> req -> IO ()) -> Maybe (LSP.Handler (NotificationMessage m req)) + {withResponse :: forall m req resp . + (ResponseMessage resp -> LSP.FromServerMessage) -> -- how to wrap a response + (IdeState -> req -> IO resp) -> -- actual work + Maybe (LSP.Handler (RequestMessage m req resp)) + ,withNotification :: forall m req . + Maybe (LSP.Handler (NotificationMessage m req)) -> -- old notification handler + (IdeState -> req -> IO ()) -> -- actual work + Maybe (LSP.Handler (NotificationMessage m req)) } +newtype PartialHandlers = PartialHandlers (WithMessage -> LSP.Handlers -> IO LSP.Handlers) + +instance Default PartialHandlers where + def = PartialHandlers $ \_ x -> pure x + +instance Semigroup PartialHandlers where + PartialHandlers a <> PartialHandlers b = PartialHandlers $ \w x -> a w x >>= b w + +instance Monoid PartialHandlers where + mempty = def ------------------------------------------------------------------------ -- Server execution diff --git a/test/Demo.hs b/test/Demo.hs index b88a6583..3b4e2e17 100644 --- a/test/Demo.hs +++ b/test/Demo.hs @@ -6,6 +6,7 @@ module Demo(main) where import Data.Maybe import Control.Concurrent.Extra import Control.Monad +import Data.Default import System.Time.Extra import Development.IDE.Core.FileStore import Development.IDE.Core.OfInterest @@ -58,7 +59,7 @@ main = do if "--lsp" `elem` args then do hPutStrLn stderr "Starting IDE server" - runLanguageServer $ \event vfs -> do + runLanguageServer def def $ \event vfs -> do hPutStrLn stderr "Server started" initialise (mainRule >> action kick) event logger options vfs else do