git.iko.soy/ghcide
on master help sign in
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

commit124a4d47dabb4831d9ac91a8b6e2a90a5f3798bf authorNeil Mitchell <35463327+neil-da@users.noreply.github.com> dateWed 26 Jun 2019, 09:04 (7 years ago) parent62cf82a
9 files changed+98−114
compare with master
unifiedsplit
BUILD.bazel+1 hie-core.cabal+1 src/Development/IDE/Core/FileStore.hs+23−7 src/Development/IDE/LSP/Definition.hs+2−2 src/Development/IDE/LSP/Hover.hs+2−2 src/Development/IDE/LSP/LanguageServer.hs+22−26 src/Development/IDE/LSP/Notifications.hs+26−74 src/Development/IDE/LSP/Server.hs+19−2 test/Demo.hs+2−1
BUILD.bazel+1
@@ -71,6 +71,7 @@ da_haskell_binary(
7171 hazel_deps = [
7272 "base",
7373 "containers",
74+ "data-default",
7475 "directory",
7576 "extra",
7677 "ghc-paths",
hie-core.cabal+1
@@ -111,6 +111,7 @@ executable hie-core
111111 directory,
112112 hie-bios,
113113 shake,
114+ data-default,
114115 ghc-paths,
115116 ghc,
116117 extra,
src/Development/IDE/Core/FileStore.hs+23−7
@@ -6,6 +6,7 @@
66module Development.IDE.Core.FileStore(
77 getFileExists, getFileContents,
88 setBufferModified,
9+ setSomethingModified,
910 fileStoreRules,
1011 VFSHandle,
1112 makeVFSHandle,
@@ -44,7 +45,10 @@ import Language.Haskell.LSP.VFS
4445-- like `setBufferModified` we abstract over the VFS implementation.
4546data VFSHandle = VFSHandle
4647 { getVirtualFile :: NormalizedUri -> IO (Maybe VirtualFile)
47− , setVirtualFileContents :: NormalizedUri -> Maybe T.Text -> IO ()
48+ -- ^ get the contents of a virtual file
49+ , setVirtualFileContents :: Maybe (NormalizedUri -> Maybe T.Text -> IO ())
50+ -- ^ set a specific file to a value. If Nothing then we are ignoring these
51+ -- signals anyway so can just say something was modified
4852 }
4953
5054instance IsIdeGlobal VFSHandle
@@ -56,7 +60,7 @@ makeVFSHandle = do
5660 { getVirtualFile = \uri -> do
5761 (_nextVersion, vfs) <- readVar vfsVar
5862 pure $ Map.lookup uri vfs
59− , setVirtualFileContents = \uri content ->
63+ , setVirtualFileContents = Just $ \uri content ->
6064 modifyVar_ vfsVar $ \(nextVersion, vfs) -> pure $ (nextVersion + 1, ) $
6165 case content of
6266 Nothing -> Map.delete uri vfs
@@ -66,9 +70,8 @@ makeVFSHandle = do
6670makeLSPVFSHandle :: LspFuncs c -> VFSHandle
6771makeLSPVFSHandle lspFuncs = VFSHandle
6872 { getVirtualFile = getVirtualFileFunc lspFuncs
69− , setVirtualFileContents = \_ _ -> pure ()
70− -- ^ Handled internally by haskell-lsp.
71− }
73+ , setVirtualFileContents = Nothing
74+ }
7275
7376
7477-- | Get the contents of a file, either dirty (if the buffer is modified) or from disk.
@@ -158,11 +161,24 @@ fileStoreRules vfs = do
158161 getFileExistsRule vfs
159162
160163
161−-- | Notify the compiler service of a modified buffer
164+-- | Notify the compiler service that a particular file has been modified.
165+-- Use 'Nothing' to say the file is no longer in the virtual file system
166+-- but should be sourced from disk, or 'Just' to give its new value.
162167setBufferModified :: IdeState -> NormalizedFilePath -> Maybe T.Text -> IO ()
163168setBufferModified state absFile contents = do
164169 VFSHandle{..} <- getIdeGlobalState state
165− setVirtualFileContents (filePathToUri' absFile) contents
170+ whenJust setVirtualFileContents $ \set ->
171+ set (filePathToUri' absFile) contents
172+ void $ shakeRun state [] (const $ pure ())
173+
174+-- | Note that some buffer somewhere has been modified, but don't say what.
175+-- Only valid if the virtual file system was initialised by LSP, as that
176+-- independently tracks which files are modified.
177+setSomethingModified :: IdeState -> IO ()
178+setSomethingModified state = do
179+ VFSHandle{..} <- getIdeGlobalState state
180+ when (isJust setVirtualFileContents) $
181+ fail "setSomethingModified can't be called on this type of VFSHandle"
166182 void $ shakeRun state [] (const $ pure ())
167183
168184
src/Development/IDE/LSP/Definition.hs+2−2
@@ -39,7 +39,7 @@ gotoDefinition ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos)
3939 Just loc -> SingleLoc loc
4040
4141
42−setHandlersDefinition :: WithMessage -> LSP.Handlers -> IO LSP.Handlers
43−setHandlersDefinition WithMessage{..} x = return x{
42+setHandlersDefinition :: PartialHandlers
43+setHandlersDefinition = PartialHandlers $ \WithMessage{..} x -> return x{
4444 LSP.definitionHandler = withResponse RspDefinition gotoDefinition
4545 }
src/Development/IDE/LSP/Hover.hs+2−2
@@ -43,7 +43,7 @@ onHover ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos) = do
4343
4444 Nothing -> pure Nothing
4545
46−setHandlersHover :: WithMessage -> LSP.Handlers -> IO LSP.Handlers
47−setHandlersHover WithMessage{..} x = return x{
46+setHandlersHover :: PartialHandlers
47+setHandlersHover = PartialHandlers $ \WithMessage{..} x -> return x{
4848 LSP.hoverHandler = withResponse RspHover onHover
4949 }
src/Development/IDE/LSP/LanguageServer.hs+22−26
@@ -18,9 +18,10 @@ import Control.Concurrent.Chan
1818import Control.Concurrent.Extra
1919import Control.Concurrent.Async
2020import Data.Default
21+import Data.Maybe
2122import GHC.IO.Handle (hDuplicate, hDuplicateTo)
2223import System.IO
23−import Control.Monad
24+import Control.Monad.Extra
2425
2526import Development.IDE.LSP.Definition
2627import Development.IDE.LSP.Hover
@@ -32,14 +33,18 @@ import Language.Haskell.LSP.Messages
3233
3334
3435runLanguageServer
35− :: ((FromServerMessage -> IO ()) -> VFSHandle -> IO IdeState)
36+ :: LSP.Options
37+ -> PartialHandlers
38+ -> ((FromServerMessage -> IO ()) -> VFSHandle -> IO IdeState)
3639 -> IO ()
37−runLanguageServer getIdeState = do
40+runLanguageServer options userHandlers getIdeState = do
3841 -- Move stdout to another file descriptor and duplicate stderr
3942 -- to stdout. This guards against stray prints from corrupting the JSON-RPC
4043 -- message stream.
4144 newStdout <- hDuplicate stdout
4245 stderr `hDuplicateTo` stdout
46+ hSetBuffering stderr NoBuffering
47+ hSetBuffering stdout NoBuffering
4348
4449 -- Print out a single space to assert that the above redirection works.
4550 -- This is interleaved with the logger, hence we just print a space here in
@@ -57,9 +62,13 @@ runLanguageServer getIdeState = do
5762 clientMsgBarrier <- newBarrier
5863
5964 let withResponse wrap f = Just $ \r -> writeChan clientMsgChan $ Response r wrap f
60− let withNotification f = Just $ \r -> writeChan clientMsgChan $ Notification r f
61− let runHandler = WithMessage{withResponse, withNotification}
62− handlers <- mergeHandlers [setHandlersDefinition, setHandlersHover, setHandlersNotifications, setHandlersIgnore] runHandler def
65+ let withNotification old f = Just $ \r -> writeChan clientMsgChan $ Notification r (\ide x -> f ide x >> whenJust old ($ r))
66+ let PartialHandlers parts =
67+ setHandlersIgnore <> -- least important
68+ setHandlersDefinition <> setHandlersHover <> -- useful features someone may override
69+ userHandlers <>
70+ setHandlersNotifications -- absolutely critical, join them with user notifications
71+ handlers <- parts WithMessage{withResponse, withNotification} def
6372
6473 void $ waitAnyCancel =<< traverse async
6574 [ void $ LSP.runWithHandles
@@ -69,7 +78,7 @@ runLanguageServer getIdeState = do
6978 , handleInit (signalBarrier clientMsgBarrier ()) clientMsgChan
7079 )
7180 handlers
72− options
81+ (modifyOptions options)
7382 Nothing
7483 , void $ waitBarrier clientMsgBarrier
7584 ]
@@ -89,20 +98,14 @@ runLanguageServer getIdeState = do
8998
9099-- | Things that get sent to us, but we don't deal with.
91100-- Set them to avoid a warning in VS Code output.
92−setHandlersIgnore :: WithMessage -> LSP.Handlers -> IO LSP.Handlers
93−setHandlersIgnore _ x = return x
101+setHandlersIgnore :: PartialHandlers
102+setHandlersIgnore = PartialHandlers $ \_ x -> return x
94103 {LSP.cancelNotificationHandler = none
95104 ,LSP.initializedHandler = none
96− ,LSP.codeLensHandler = none -- FIXME: Stop saying we support it in 'options'
97105 }
98106 where none = Just $ const $ return ()
99107
100108
101−mergeHandlers :: [WithMessage -> LSP.Handlers -> IO LSP.Handlers] -> WithMessage -> LSP.Handlers -> IO LSP.Handlers
102−mergeHandlers = foldl f (\_ a -> return a)
103− where f x1 x2 r a = x1 r a >>= x2 r
104−
105−
106109-- | A message that we need to deal with - the pieces are split up with existentials to gain additional type safety
107110-- and defer precise processing until later (allows us to keep at a higher level of abstraction slightly longer)
108111data Message
@@ -110,14 +113,7 @@ data Message
110113 | forall m req . Notification (NotificationMessage m req) (IdeState -> req -> IO ())
111114
112115
113−options :: LSP.Options
114−options = def
115− { LSP.textDocumentSync = Just TextDocumentSyncOptions
116− { _openClose = Just True
117− , _change = Just TdSyncIncremental
118− , _willSave = Nothing
119− , _willSaveWaitUntil = Nothing
120− , _save = Just $ SaveOptions $ Just False
121− }
122− , LSP.codeLensProvider = Just $ CodeLensOptions $ Just False
123− }
116+modifyOptions :: LSP.Options -> LSP.Options
117+modifyOptions x = x{LSP.textDocumentSync = Just orig{_openClose=Just True, _change=Just TdSyncIncremental}}
118+ where orig = fromMaybe tdsDefault $ LSP.textDocumentSync x
119+ tdsDefault = TextDocumentSyncOptions Nothing Nothing Nothing Nothing Nothing
src/Development/IDE/LSP/Notifications.hs+26−74
@@ -12,89 +12,41 @@ module Development.IDE.LSP.Notifications
1212import Development.IDE.LSP.Protocol
1313import Development.IDE.LSP.Server hiding (runServer)
1414import qualified Language.Haskell.LSP.Core as LSP
15+import qualified Language.Haskell.LSP.Types as LSP
1516
1617import Development.IDE.Types.Logger
1718import Development.IDE.Core.Service
1819import Development.IDE.Types.Location
1920
2021import qualified Data.Set as S
21−import qualified Data.Text as T
2222
2323import Development.IDE.Core.FileStore
2424import Development.IDE.Core.OfInterest
2525
26−import qualified Network.URI as URI
27−
28−
29−textShow :: Show a => a -> T.Text
30−textShow = T.pack . show
31−
32−
33−setHandlersNotifications :: WithMessage -> LSP.Handlers -> IO LSP.Handlers
34−setHandlersNotifications WithMessage{..} x = return x{
35− LSP.didOpenTextDocumentNotificationHandler = withNotification $ \ide (DidOpenTextDocumentParams item) -> do
36− case URI.parseURI $ T.unpack $ getUri $ _uri (item :: TextDocumentItem) of
37− Just uri
38− | URI.uriScheme uri == "file:"
39− -> handleDidOpenFile ide item
40−
41− | otherwise
42− -> logWarning (ideLogger ide) $ "Unknown scheme in URI: "
43− <> textShow uri
44−
45− _ -> logSeriousError (ideLogger ide) $ "Invalid URI in DidOpenTextDocument: "
46− <> textShow (_uri (item :: TextDocumentItem))
47−
48− ,LSP.didChangeTextDocumentNotificationHandler = withNotification $ \ide (DidChangeTextDocumentParams docId _) -> do
49− let uri = _uri (docId :: VersionedTextDocumentIdentifier)
50−
51− case uriToFilePath' uri of
52− Just (toNormalizedFilePath -> filePath) -> do
53− onFileModified ide filePath
54− logInfo (ideLogger ide)
55− $ "Updated text document: " <> textShow (fromNormalizedFilePath filePath)
56−
57− Nothing ->
58− logSeriousError (ideLogger ide)
59− $ "Invalid file path: " <> textShow (_uri (docId :: VersionedTextDocumentIdentifier))
60−
61− ,LSP.didCloseTextDocumentNotificationHandler = withNotification $ \ide (DidCloseTextDocumentParams (TextDocumentIdentifier uri)) ->
62− case URI.parseURI $ T.unpack $ getUri uri of
63− Just uri'
64− | URI.uriScheme uri' == "file:" -> do
65− Just fp <- pure $ toNormalizedFilePath <$> uriToFilePath' uri
66− handleDidCloseFile ide fp
67− | otherwise -> logWarning (ideLogger ide) $ "Unknown scheme in URI: " <> textShow uri
68−
69− _ -> logSeriousError (ideLogger ide)
70− $ "Invalid URI in DidCloseTextDocument: "
71− <> textShow uri
7226
27+whenUriFile :: IdeState -> Uri -> (NormalizedFilePath -> IO ()) -> IO ()
28+whenUriFile ide uri act = case LSP.uriToFilePath uri of
29+ Just file -> act $ toNormalizedFilePath file
30+ Nothing -> logWarning (ideLogger ide) $ "Unknown scheme in URI: " <> getUri uri
31+
32+setHandlersNotifications :: PartialHandlers
33+setHandlersNotifications = PartialHandlers $ \WithMessage{..} x -> return x
34+ {LSP.didOpenTextDocumentNotificationHandler = withNotification (LSP.didOpenTextDocumentNotificationHandler x) $
35+ \ide (DidOpenTextDocumentParams TextDocumentItem{_uri}) -> do
36+ setSomethingModified ide
37+ whenUriFile ide _uri $ \file ->
38+ modifyFilesOfInterest ide (S.insert file)
39+ logInfo (ideLogger ide) $ "Opened text document: " <> getUri _uri
40+
41+ ,LSP.didChangeTextDocumentNotificationHandler = withNotification (LSP.didChangeTextDocumentNotificationHandler x) $
42+ \ide (DidChangeTextDocumentParams VersionedTextDocumentIdentifier{_uri} _) -> do
43+ setSomethingModified ide
44+ logInfo (ideLogger ide) $ "Modified text document: " <> getUri _uri
45+
46+ ,LSP.didCloseTextDocumentNotificationHandler = withNotification (LSP.didCloseTextDocumentNotificationHandler x) $
47+ \ide (DidCloseTextDocumentParams TextDocumentIdentifier{_uri}) -> do
48+ setSomethingModified ide
49+ whenUriFile ide _uri $ \file ->
50+ modifyFilesOfInterest ide (S.delete file)
51+ logInfo (ideLogger ide) $ "Closed text document: " <> getUri _uri
7352 }
74− where
75− -- Note that the state changes here are not atomic.
76− -- When we have parallel compilation we could manage the state
77− -- changes in STM so that we can atomically change the state.
78− -- Internally it should be done via the IO oracle. See PROD-2808.
79− handleDidOpenFile ide (TextDocumentItem uri _ _ _) = do
80− Just filePath <- pure $ toNormalizedFilePath <$> uriToFilePath' uri
81− onFileModified ide filePath
82− modifyFilesOfInterest ide (S.insert filePath)
83− logInfo (ideLogger ide) $ "Opened text document: " <> textShow filePath
84−
85− handleDidCloseFile ide filePath = do
86− logInfo (ideLogger ide) $ "Closed text document: " <> textShow (fromNormalizedFilePath filePath)
87− onFileModified ide filePath
88− modifyFilesOfInterest ide (S.delete filePath)
89−
90−
91−-- | Manages the file store (caching compilation results and unsaved content).
92−onFileModified
93− :: IdeState
94− -> NormalizedFilePath
95− -> IO ()
96−onFileModified service fp = do
97− logDebug (ideLogger service) $ "File modified " <> T.pack (show fp)
98− -- if we get here then we must be using the LSP framework, in which case we don't
99− -- need to bother sending file modifications, other than to force the database to rerun
100− setBufferModified service fp Nothing
src/Development/IDE/LSP/Server.hs+19−2
@@ -8,6 +8,7 @@ module Development.IDE.LSP.Server
88 ( runServer
99 , Handlers(..)
1010 , WithMessage(..)
11+ , PartialHandlers(..)
1112 ) where
1213
1314
@@ -38,10 +39,26 @@ import Development.IDE.Core.Service
3839
3940
4041data WithMessage = WithMessage
41− {withResponse :: forall m req resp . (ResponseMessage resp -> LSP.FromServerMessage) -> (IdeState -> req -> IO resp) -> Maybe (LSP.Handler (RequestMessage m req resp))
42− ,withNotification :: forall m req . (IdeState -> req -> IO ()) -> Maybe (LSP.Handler (NotificationMessage m req))
42+ {withResponse :: forall m req resp .
43+ (ResponseMessage resp -> LSP.FromServerMessage) -> -- how to wrap a response
44+ (IdeState -> req -> IO resp) -> -- actual work
45+ Maybe (LSP.Handler (RequestMessage m req resp))
46+ ,withNotification :: forall m req .
47+ Maybe (LSP.Handler (NotificationMessage m req)) -> -- old notification handler
48+ (IdeState -> req -> IO ()) -> -- actual work
49+ Maybe (LSP.Handler (NotificationMessage m req))
4350 }
4451
52+newtype PartialHandlers = PartialHandlers (WithMessage -> LSP.Handlers -> IO LSP.Handlers)
53+
54+instance Default PartialHandlers where
55+ def = PartialHandlers $ \_ x -> pure x
56+
57+instance Semigroup PartialHandlers where
58+ PartialHandlers a <> PartialHandlers b = PartialHandlers $ \w x -> a w x >>= b w
59+
60+instance Monoid PartialHandlers where
61+ mempty = def
4562
4663------------------------------------------------------------------------
4764-- Server execution
test/Demo.hs+2−1
@@ -6,6 +6,7 @@ module Demo(main) where
66import Data.Maybe
77import Control.Concurrent.Extra
88import Control.Monad
9+import Data.Default
910import System.Time.Extra
1011import Development.IDE.Core.FileStore
1112import Development.IDE.Core.OfInterest
@@ -58,7 +59,7 @@ main = do
5859
5960 if "--lsp" `elem` args then do
6061 hPutStrLn stderr "Starting IDE server"
61− runLanguageServer $ \event vfs -> do
62+ runLanguageServer def def $ \event vfs -> do
6263 hPutStrLn stderr "Server started"
6364 initialise (mainRule >> action kick) event logger options vfs
6465 else do