mirror of
https://github.com/haskell/ghcide.git
synced 2024-09-11 05:36:09 +03:00
Fully asynchronous request handling (#767)
* Cancellation of user actions * Dispatch event handlers asynchronously * add tests for asynchronous features This adds a new Test plugin for custom requests and a new blocking Command * hlint * Link the Testing plugin only when --testing * Fix expectNoMoreDiagnostics Needs also https://github.com/bubba/lsp-test/pull/74 * Upgrade lsp-test to a version that understands CustomClientMethod
This commit is contained in:
parent
0d7cae9846
commit
684be6885d
@ -30,6 +30,7 @@ import Development.IDE.Types.Logger
|
||||
import Development.IDE.Plugin
|
||||
import Development.IDE.Plugin.Completions as Completions
|
||||
import Development.IDE.Plugin.CodeAction as CodeAction
|
||||
import Development.IDE.Plugin.Test as Test
|
||||
import Development.IDE.Session
|
||||
import qualified Language.Haskell.LSP.Core as LSP
|
||||
import Language.Haskell.LSP.Messages
|
||||
@ -81,6 +82,7 @@ main = do
|
||||
command <- makeLspCommandId "typesignature.add"
|
||||
|
||||
let plugins = Completions.plugin <> CodeAction.plugin
|
||||
<> if argsTesting then Test.plugin else mempty
|
||||
onInitialConfiguration :: InitializeRequest -> Either T.Text LspConfig
|
||||
onInitialConfiguration x = case x ^. params . initializationOptions of
|
||||
Nothing -> Right defaultLspConfig
|
||||
|
@ -147,6 +147,7 @@ library
|
||||
Development.IDE.Plugin
|
||||
Development.IDE.Plugin.Completions
|
||||
Development.IDE.Plugin.CodeAction
|
||||
Development.IDE.Plugin.Test
|
||||
|
||||
-- Unfortunately, we cannot use loadSession with ghc-lib since hie-bios uses
|
||||
-- the real GHC library and the types are incompatible. Furthermore, when
|
||||
@ -337,7 +338,7 @@ test-suite ghcide-tests
|
||||
haskell-lsp-types,
|
||||
network-uri,
|
||||
lens,
|
||||
lsp-test >= 0.11.0.1 && < 0.12,
|
||||
lsp-test >= 0.11.0.5 && < 0.12,
|
||||
optparse-applicative,
|
||||
process,
|
||||
QuickCheck,
|
||||
|
@ -567,13 +567,20 @@ shakeRestart IdeState{..} acts =
|
||||
--
|
||||
-- Appropriate for user actions other than edits.
|
||||
shakeEnqueue :: ShakeExtras -> DelayedAction a -> IO (IO a)
|
||||
shakeEnqueue ShakeExtras{actionQueue} act = do
|
||||
shakeEnqueue ShakeExtras{actionQueue, logger} act = do
|
||||
(b, dai) <- instantiateDelayedAction act
|
||||
atomically $ pushQueue dai actionQueue
|
||||
let wait' b =
|
||||
waitBarrier b `catch` \BlockedIndefinitelyOnMVar ->
|
||||
fail $ "internal bug: forever blocked on MVar for " <>
|
||||
actionName act
|
||||
waitBarrier b `catches`
|
||||
[ Handler(\BlockedIndefinitelyOnMVar ->
|
||||
fail $ "internal bug: forever blocked on MVar for " <>
|
||||
actionName act)
|
||||
, Handler (\e@AsyncCancelled -> do
|
||||
logPriority logger Debug $ T.pack $ actionName act <> " was cancelled"
|
||||
|
||||
atomically $ abortQueue dai actionQueue
|
||||
throw e)
|
||||
]
|
||||
return (wait' b >>= either throwIO return)
|
||||
|
||||
-- | Set up a new 'ShakeSession' with a set of initial actions
|
||||
|
@ -71,6 +71,8 @@ runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeStat
|
||||
-- This should not happen but if it does, we will make sure that the whole server
|
||||
-- dies and can be restarted instead of losing threads silently.
|
||||
clientMsgBarrier <- newBarrier
|
||||
-- Forcefully exit
|
||||
let exit = signalBarrier clientMsgBarrier ()
|
||||
|
||||
-- The set of requests ids that we have received but not finished processing
|
||||
pendingRequests <- newTVarIO Set.empty
|
||||
@ -107,7 +109,8 @@ runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeStat
|
||||
setHandlersOutline <>
|
||||
userHandlers <>
|
||||
setHandlersNotifications <> -- absolutely critical, join them with user notifications
|
||||
cancelHandler cancelRequest
|
||||
cancelHandler cancelRequest <>
|
||||
exitHandler exit
|
||||
-- Cancel requests are special since they need to be handled
|
||||
-- out of order to be useful. Existing handlers are run afterwards.
|
||||
handlers <- parts WithMessage{withResponse, withNotification, withResponseAndRequest, withInitialize} def
|
||||
@ -115,7 +118,7 @@ runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeStat
|
||||
let initializeCallbacks = LSP.InitializeCallbacks
|
||||
{ LSP.onInitialConfiguration = onInitialConfig
|
||||
, LSP.onConfigurationChange = onConfigChange
|
||||
, LSP.onStartup = handleInit (signalBarrier clientMsgBarrier ()) clearReqId waitForCancel clientMsgChan
|
||||
, LSP.onStartup = handleInit exit clearReqId waitForCancel clientMsgChan
|
||||
}
|
||||
|
||||
void $ waitAnyCancel =<< traverse async
|
||||
@ -137,7 +140,8 @@ runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeStat
|
||||
|
||||
_ <- flip forkFinally (const exitClientMsg) $ forever $ do
|
||||
msg <- readChan clientMsgChan
|
||||
case msg of
|
||||
-- dispatch the work to a new thread
|
||||
void $ async $ case msg of
|
||||
Notification x@NotificationMessage{_params} act -> do
|
||||
catch (act lspFuncs ide _params) $ \(e :: SomeException) ->
|
||||
logError (ideLogger ide) $ T.pack $
|
||||
@ -217,6 +221,9 @@ cancelHandler cancelRequest = PartialHandlers $ \_ x -> return x
|
||||
whenJust (LSP.cancelNotificationHandler x) ($ msg)
|
||||
}
|
||||
|
||||
exitHandler :: IO () -> PartialHandlers c
|
||||
exitHandler exit = PartialHandlers $ \_ x -> return x
|
||||
{LSP.exitNotificationHandler = Just $ const exit}
|
||||
|
||||
-- | 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)
|
||||
|
@ -14,7 +14,11 @@ module Development.IDE.Plugin.CodeAction
|
||||
, codeAction
|
||||
, codeLens
|
||||
, rulePackageExports
|
||||
, executeAddSignatureCommand
|
||||
, commandHandler
|
||||
|
||||
-- * For testing
|
||||
, blockCommandId
|
||||
, typeSignatureCommandId
|
||||
) where
|
||||
|
||||
import Control.Monad (join, guard)
|
||||
@ -58,8 +62,8 @@ import Data.Functor
|
||||
import Control.Applicative ((<|>))
|
||||
import Safe (atMay)
|
||||
import Bag (isEmptyBag)
|
||||
import Control.Concurrent.Extra (readVar)
|
||||
import qualified Data.HashSet as Set
|
||||
import Control.Concurrent.Extra (threadDelay, readVar)
|
||||
|
||||
plugin :: Plugin c
|
||||
plugin = codeActionPluginWithRules rules codeAction <> Plugin mempty setHandlersCodeLens
|
||||
@ -67,6 +71,13 @@ plugin = codeActionPluginWithRules rules codeAction <> Plugin mempty setHandlers
|
||||
rules :: Rules ()
|
||||
rules = rulePackageExports
|
||||
|
||||
-- | a command that blocks forever. Used for testing
|
||||
blockCommandId :: T.Text
|
||||
blockCommandId = "ghcide.command.block"
|
||||
|
||||
typeSignatureCommandId :: T.Text
|
||||
typeSignatureCommandId = "typesignature.add"
|
||||
|
||||
-- | Generate code actions.
|
||||
codeAction
|
||||
:: LSP.LspFuncs c
|
||||
@ -117,17 +128,23 @@ codeLens _lsp ideState CodeLensParams{_textDocument=TextDocumentIdentifier uri}
|
||||
Nothing -> pure []
|
||||
|
||||
-- | Execute the "typesignature.add" command.
|
||||
executeAddSignatureCommand
|
||||
commandHandler
|
||||
:: LSP.LspFuncs c
|
||||
-> IdeState
|
||||
-> ExecuteCommandParams
|
||||
-> IO (Either ResponseError Value, Maybe (ServerMethod, ApplyWorkspaceEditParams))
|
||||
executeAddSignatureCommand _lsp _ideState ExecuteCommandParams{..}
|
||||
commandHandler lsp _ideState ExecuteCommandParams{..}
|
||||
-- _command is prefixed with a process ID, because certain clients
|
||||
-- have a global command registry, and all commands must be
|
||||
-- unique. And there can be more than one ghcide instance running
|
||||
-- at a time against the same client.
|
||||
| T.isSuffixOf "typesignature.add" _command
|
||||
| T.isSuffixOf blockCommandId _command
|
||||
= do
|
||||
LSP.sendFunc lsp $ NotCustomServer $
|
||||
NotificationMessage "2.0" (CustomServerMethod "ghcide/blocking/command") Null
|
||||
threadDelay maxBound
|
||||
return (Right Null, Nothing)
|
||||
| T.isSuffixOf typeSignatureCommandId _command
|
||||
, Just (List [edit]) <- _arguments
|
||||
, Success wedit <- fromJSON edit
|
||||
= return (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams wedit))
|
||||
@ -1058,8 +1075,13 @@ matchRegex message regex = case message =~~ regex of
|
||||
|
||||
setHandlersCodeLens :: PartialHandlers c
|
||||
setHandlersCodeLens = PartialHandlers $ \WithMessage{..} x -> return x{
|
||||
LSP.codeLensHandler = withResponse RspCodeLens codeLens,
|
||||
LSP.executeCommandHandler = withResponseAndRequest RspExecuteCommand ReqApplyWorkspaceEdit executeAddSignatureCommand
|
||||
LSP.codeLensHandler =
|
||||
withResponse RspCodeLens codeLens,
|
||||
LSP.executeCommandHandler =
|
||||
withResponseAndRequest
|
||||
RspExecuteCommand
|
||||
ReqApplyWorkspaceEdit
|
||||
commandHandler
|
||||
}
|
||||
|
||||
filterNewlines :: T.Text -> T.Text
|
||||
|
64
src/Development/IDE/Plugin/Test.hs
Normal file
64
src/Development/IDE/Plugin/Test.hs
Normal file
@ -0,0 +1,64 @@
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
-- | A plugin that adds custom messages for use in tests
|
||||
module Development.IDE.Plugin.Test (TestRequest(..), plugin) where
|
||||
|
||||
import Control.Monad.STM
|
||||
import Data.Aeson
|
||||
import Data.Aeson.Types
|
||||
import Development.IDE.Core.Service
|
||||
import Development.IDE.Core.Shake
|
||||
import Development.IDE.GHC.Compat
|
||||
import Development.IDE.GHC.Util (HscEnvEq(hscEnv))
|
||||
import Development.IDE.LSP.Server
|
||||
import Development.IDE.Plugin
|
||||
import Development.IDE.Types.Action
|
||||
import GHC.Generics (Generic)
|
||||
import GhcPlugins (HscEnv(hsc_dflags))
|
||||
import Language.Haskell.LSP.Core
|
||||
import Language.Haskell.LSP.Messages
|
||||
import Language.Haskell.LSP.Types
|
||||
import System.Time.Extra
|
||||
import Development.IDE.Core.RuleTypes
|
||||
|
||||
data TestRequest
|
||||
= BlockSeconds Seconds -- ^ :: Null
|
||||
| GetInterfaceFilesDir FilePath -- ^ :: String
|
||||
| GetShakeSessionQueueCount -- ^ :: Number
|
||||
deriving Generic
|
||||
deriving anyclass (FromJSON, ToJSON)
|
||||
|
||||
plugin :: Plugin c
|
||||
plugin = Plugin {
|
||||
pluginRules = return (),
|
||||
pluginHandler = PartialHandlers $ \WithMessage{..} x -> return x {
|
||||
customRequestHandler = withResponse RspCustomServer requestHandler'
|
||||
}
|
||||
}
|
||||
where
|
||||
requestHandler' lsp ide req
|
||||
| Just customReq <- parseMaybe parseJSON req
|
||||
= requestHandler lsp ide customReq
|
||||
| otherwise
|
||||
= return $ Left
|
||||
$ ResponseError InvalidRequest "Cannot parse request" Nothing
|
||||
|
||||
requestHandler :: LspFuncs c
|
||||
-> IdeState
|
||||
-> TestRequest
|
||||
-> IO (Either ResponseError Value)
|
||||
requestHandler lsp _ (BlockSeconds secs) = do
|
||||
sendFunc lsp $ NotCustomServer $
|
||||
NotificationMessage "2.0" (CustomServerMethod "ghcide/blocking/request") $
|
||||
toJSON secs
|
||||
sleep secs
|
||||
return (Right Null)
|
||||
requestHandler _ s (GetInterfaceFilesDir fp) = do
|
||||
let nfp = toNormalizedFilePath fp
|
||||
sess <- runAction "Test - GhcSession" s $ use_ GhcSession nfp
|
||||
let hiPath = hiDir $ hsc_dflags $ hscEnv sess
|
||||
return $ Right (toJSON hiPath)
|
||||
requestHandler _ s GetShakeSessionQueueCount = do
|
||||
n <- atomically $ countQueue $ actionQueue $ shakeExtras s
|
||||
return $ Right (toJSON n)
|
||||
|
@ -7,19 +7,17 @@ module Development.IDE.Types.Action
|
||||
popQueue,
|
||||
doneQueue,
|
||||
peekInProgress,
|
||||
)
|
||||
abortQueue,countQueue)
|
||||
where
|
||||
|
||||
import Control.Concurrent.STM (STM, TQueue, TVar, atomically,
|
||||
modifyTVar, newTQueue, newTVar,
|
||||
readTQueue, readTVar,
|
||||
writeTQueue)
|
||||
import Control.Concurrent.STM
|
||||
import Data.Hashable (Hashable (..))
|
||||
import Data.HashSet (HashSet)
|
||||
import qualified Data.HashSet as Set
|
||||
import Data.Unique (Unique)
|
||||
import Development.IDE.Types.Logger
|
||||
import Development.Shake (Action)
|
||||
import Numeric.Natural
|
||||
|
||||
data DelayedAction a = DelayedAction
|
||||
{ uniqueID :: Maybe Unique,
|
||||
@ -67,9 +65,24 @@ popQueue ActionQueue {..} = do
|
||||
return x
|
||||
|
||||
-- | Completely remove an action from the queue
|
||||
doneQueue :: DelayedActionInternal -> ActionQueue -> STM ()
|
||||
doneQueue x ActionQueue {..} =
|
||||
abortQueue :: DelayedActionInternal -> ActionQueue -> STM ()
|
||||
abortQueue x ActionQueue {..} = do
|
||||
qq <- flushTQueue newActions
|
||||
mapM_ (writeTQueue newActions) (filter (/= x) qq)
|
||||
modifyTVar inProgress (Set.delete x)
|
||||
|
||||
-- | Mark an action as complete when called after 'popQueue'.
|
||||
-- Has no effect otherwise
|
||||
doneQueue :: DelayedActionInternal -> ActionQueue -> STM ()
|
||||
doneQueue x ActionQueue {..} = do
|
||||
modifyTVar inProgress (Set.delete x)
|
||||
|
||||
countQueue :: ActionQueue -> STM Natural
|
||||
countQueue ActionQueue{..} = do
|
||||
backlog <- flushTQueue newActions
|
||||
mapM_ (writeTQueue newActions) backlog
|
||||
m <- Set.size <$> readTVar inProgress
|
||||
return $ fromIntegral $ length backlog + m
|
||||
|
||||
peekInProgress :: ActionQueue -> STM [DelayedActionInternal]
|
||||
peekInProgress ActionQueue {..} = Set.toList <$> readTVar inProgress
|
||||
|
@ -4,7 +4,7 @@ packages:
|
||||
extra-deps:
|
||||
- haskell-lsp-0.22.0.0
|
||||
- haskell-lsp-types-0.22.0.0
|
||||
- lsp-test-0.11.0.2
|
||||
- lsp-test-0.11.0.5
|
||||
- extra-1.7.2
|
||||
- hie-bios-0.6.1
|
||||
- ghc-lib-parser-8.8.1
|
||||
|
@ -4,7 +4,7 @@ packages:
|
||||
extra-deps:
|
||||
- haskell-lsp-0.22.0.0
|
||||
- haskell-lsp-types-0.22.0.0
|
||||
- lsp-test-0.11.0.2
|
||||
- lsp-test-0.11.0.5
|
||||
- hie-bios-0.6.1
|
||||
- fuzzy-0.1.0.0
|
||||
- regex-pcre-builtin-0.95.1.1.8.43
|
||||
|
@ -5,7 +5,7 @@ packages:
|
||||
extra-deps:
|
||||
- haskell-lsp-0.22.0.0
|
||||
- haskell-lsp-types-0.22.0.0
|
||||
- lsp-test-0.11.0.2
|
||||
- lsp-test-0.11.0.5
|
||||
- ghc-check-0.5.0.1
|
||||
- hie-bios-0.6.1
|
||||
|
||||
|
@ -7,7 +7,7 @@ extra-deps:
|
||||
- base-orphans-0.8.2
|
||||
- haskell-lsp-0.22.0.0
|
||||
- haskell-lsp-types-0.22.0.0
|
||||
- lsp-test-0.11.0.2
|
||||
- lsp-test-0.11.0.5
|
||||
- rope-utf16-splay-0.3.1.0
|
||||
- filepattern-0.1.1
|
||||
- js-dgtable-0.5.2
|
||||
|
@ -4,7 +4,7 @@ packages:
|
||||
extra-deps:
|
||||
- haskell-lsp-0.22.0.0
|
||||
- haskell-lsp-types-0.22.0.0
|
||||
- lsp-test-0.11.0.2
|
||||
- lsp-test-0.11.0.5
|
||||
- ghc-check-0.5.0.1
|
||||
- hie-bios-0.6.1
|
||||
- extra-1.7.2
|
||||
|
@ -55,6 +55,8 @@ import Test.Tasty.Ingredients.Rerun
|
||||
import Test.Tasty.HUnit
|
||||
import Test.Tasty.QuickCheck
|
||||
import System.Time.Extra
|
||||
import Development.IDE.Plugin.CodeAction (typeSignatureCommandId, blockCommandId)
|
||||
import Development.IDE.Plugin.Test (TestRequest(BlockSeconds))
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
@ -90,6 +92,7 @@ main = do
|
||||
, ifaceTests
|
||||
, bootTests
|
||||
, rootUriTests
|
||||
, asyncTests
|
||||
]
|
||||
|
||||
initializeResponseTests :: TestTree
|
||||
@ -127,7 +130,7 @@ initializeResponseTests = withResource acquire release tests where
|
||||
, chk "NO doc link" _documentLinkProvider Nothing
|
||||
, chk "NO color" _colorProvider (Just $ ColorOptionsStatic False)
|
||||
, chk "NO folding range" _foldingRangeProvider (Just $ FoldingRangeOptionsStatic False)
|
||||
, che " execute command" _executeCommandProvider (Just $ ExecuteCommandOptions $ List ["typesignature.add"])
|
||||
, che " execute command" _executeCommandProvider (Just $ ExecuteCommandOptions $ List [typeSignatureCommandId, blockCommandId])
|
||||
, chk " workspace" _workspace (Just $ WorkspaceOptions (Just WorkspaceFolderOptions{_supported = Just True, _changeNotifications = Just ( WorkspaceFolderChangeNotificationsBool True )}))
|
||||
, chk "NO experimental" _experimental Nothing
|
||||
] where
|
||||
@ -3152,6 +3155,35 @@ rootUriTests = testCase "use rootUri" . withoutStackEnv . runTest "dirA" "dirB"
|
||||
runTest :: FilePath -> FilePath -> (FilePath -> Session ()) -> IO ()
|
||||
runTest dir1 dir2 s = withTempDir $ \dir -> runInDir' dir dir1 dir2 (s dir)
|
||||
|
||||
-- | Test if ghcide asynchronously handles Commands and user Requests
|
||||
asyncTests :: TestTree
|
||||
asyncTests = testGroup "async"
|
||||
[
|
||||
testSession "command" $ do
|
||||
-- Execute a command that will block forever
|
||||
let req = ExecuteCommandParams blockCommandId Nothing Nothing
|
||||
void $ sendRequest WorkspaceExecuteCommand req
|
||||
-- Load a file and check for code actions. Will only work if the command is run asynchronously
|
||||
doc <- createDoc "A.hs" "haskell" $ T.unlines
|
||||
[ "{-# OPTIONS -Wmissing-signatures #-}"
|
||||
, "foo = id"
|
||||
]
|
||||
void waitForDiagnostics
|
||||
actions <- getCodeActions doc (Range (Position 1 0) (Position 1 0))
|
||||
liftIO $ [ _title | CACodeAction CodeAction{_title} <- actions] @=? ["add signature: foo :: a -> a"]
|
||||
, testSession "request" $ do
|
||||
-- Execute a custom request that will block for 1000 seconds
|
||||
void $ sendRequest (CustomClientMethod "test") $ BlockSeconds 1000
|
||||
-- Load a file and check for code actions. Will only work if the request is run asynchronously
|
||||
doc <- createDoc "A.hs" "haskell" $ T.unlines
|
||||
[ "{-# OPTIONS -Wmissing-signatures #-}"
|
||||
, "foo = id"
|
||||
]
|
||||
void waitForDiagnostics
|
||||
actions <- getCodeActions doc (Range (Position 0 0) (Position 0 0))
|
||||
liftIO $ [ _title | CACodeAction CodeAction{_title} <- actions] @=? ["add signature: foo :: a -> a"]
|
||||
]
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- Utils
|
||||
----------------------------------------------------------------------
|
||||
@ -3239,7 +3271,7 @@ runInDir' dir startExeIn startSessionIn s = do
|
||||
-- If you uncomment this you can see all logging
|
||||
-- which can be quite useful for debugging.
|
||||
-- { logStdErr = True, logColor = False }
|
||||
-- If you really want to, you can also see all messages
|
||||
-- If you really want to, you can also see all messages
|
||||
-- { logMessages = True, logColor = False }
|
||||
|
||||
openTestDataDoc :: FilePath -> Session TextDocumentIdentifier
|
||||
|
@ -70,9 +70,9 @@ expectNoMoreDiagnostics timeout = do
|
||||
"Got unexpected diagnostics for " <> show fileUri <>
|
||||
" got " <> show actual
|
||||
handleCustomMethodResponse =
|
||||
-- the CustomClientMethod triggers a log message about ignoring it
|
||||
-- the CustomClientMethod triggers a RspCustomServer
|
||||
-- handle that and then exit
|
||||
void (LspTest.message :: Session LogMessageNotification)
|
||||
void (LspTest.message :: Session CustomResponse)
|
||||
ignoreOthers = void anyMessage >> handleMessages
|
||||
|
||||
expectDiagnostics :: [(FilePath, [(DiagnosticSeverity, Cursor, T.Text)])] -> Session ()
|
||||
|
Loading…
Reference in New Issue
Block a user