From cad0a94229ee03fbdb60987caec44ec8f689513a Mon Sep 17 00:00:00 2001 From: Jose Lorenzo Rodriguez Date: Sun, 7 Oct 2018 21:54:46 +0200 Subject: [PATCH 01/11] Refactor parts of the Dispatcher out to a Scheduler module This hides the details of the dispatcher away from the reactor and keeps the code more focused --- app/MainHie.hs | 12 +- haskell-ide-engine.cabal | 2 + src/Haskell/Ide/Engine/Channel.hs | 52 +++++++ src/Haskell/Ide/Engine/Dispatcher.hs | 59 ++------ src/Haskell/Ide/Engine/LSP/Reactor.hs | 64 ++++----- src/Haskell/Ide/Engine/Scheduler.hs | 135 ++++++++++++++++++ src/Haskell/Ide/Engine/Transport/JsonStdio.hs | 30 ++-- src/Haskell/Ide/Engine/Transport/LspStdio.hs | 61 ++------ 8 files changed, 258 insertions(+), 157 deletions(-) create mode 100644 src/Haskell/Ide/Engine/Channel.hs create mode 100644 src/Haskell/Ide/Engine/Scheduler.hs diff --git a/app/MainHie.hs b/app/MainHie.hs index eb7f189b2..3ff44185a 100644 --- a/app/MainHie.hs +++ b/app/MainHie.hs @@ -2,17 +2,15 @@ {-# LANGUAGE RankNTypes #-} module Main where -import Control.Concurrent.STM.TChan import Control.Monad -import Control.Monad.STM import Data.Monoid ((<>)) import Data.Version (showVersion) import qualified GhcMod.Types as GM -import Haskell.Ide.Engine.Dispatcher import Haskell.Ide.Engine.MonadFunctions import Haskell.Ide.Engine.MonadTypes import Haskell.Ide.Engine.Options import Haskell.Ide.Engine.PluginDescriptor +import Haskell.Ide.Engine.Scheduler import Haskell.Ide.Engine.Transport.LspStdio import Haskell.Ide.Engine.Transport.JsonStdio import qualified Language.Haskell.LSP.Core as Core @@ -143,8 +141,8 @@ run opts = do -- launch the dispatcher. if optJson opts then do - pin <- atomically newTChan - jsonStdioTransport (dispatcherP pin plugins' ghcModOptions) pin + scheduler <- newScheduler plugins' ghcModOptions + jsonStdioTransport scheduler else do - pin <- atomically newTChan - lspStdioTransport (dispatcherP pin plugins' ghcModOptions) pin origDir plugins' (optCaptureFile opts) + scheduler <- newScheduler plugins' ghcModOptions + lspStdioTransport scheduler origDir plugins' (optCaptureFile opts) diff --git a/haskell-ide-engine.cabal b/haskell-ide-engine.cabal index 98a826d18..ec9c20f09 100644 --- a/haskell-ide-engine.cabal +++ b/haskell-ide-engine.cabal @@ -20,7 +20,9 @@ flag pedantic library hs-source-dirs: src exposed-modules: Haskell.Ide.Engine.Plugin.Base + Haskell.Ide.Engine.Channel Haskell.Ide.Engine.Dispatcher + Haskell.Ide.Engine.Scheduler Haskell.Ide.Engine.LSP.CodeActions Haskell.Ide.Engine.LSP.Config Haskell.Ide.Engine.LSP.Reactor diff --git a/src/Haskell/Ide/Engine/Channel.hs b/src/Haskell/Ide/Engine/Channel.hs new file mode 100644 index 000000000..5a88f2b60 --- /dev/null +++ b/src/Haskell/Ide/Engine/Channel.hs @@ -0,0 +1,52 @@ +module Haskell.Ide.Engine.Channel + ( InChan + , OutChan + , newChan + , newChanSTM + , readChan + , readChanSTM + , writeChan + , writeChanSTM + ) +where + +import qualified Control.Concurrent.STM.TChan as TChan +import qualified Control.Concurrent.STM as STM + +-- | The writing end of a STM channel, only values of type 'a' cam be written +-- to the channel +newtype InChan a = InChan (TChan.TChan a) + +-- | The reading end of a STM channel, values of type 'a' can be expected to +-- be read. +newtype OutChan a = OutChan (TChan.TChan a) + +-- | Returns the reading and writing ends of a channel able to trasmit values of +-- a single given type +newChan :: IO (InChan a, OutChan a) +newChan = STM.atomically newChanSTM + +-- | STM version of 'newChan', useful for chaining many STM calls inside a single +-- 'atomically' block. +newChanSTM :: STM.STM (InChan a, OutChan a) +newChanSTM = do + chan <- TChan.newTChan + return (InChan chan, OutChan chan) + +-- | Consumes and returns the next value of the given channel +readChan :: OutChan a -> IO a +readChan = STM.atomically . readChanSTM + +-- | STM version of 'readChan', useful for chaining many STM calls inside a single +-- 'atomically' block. +readChanSTM :: OutChan a -> STM.STM a +readChanSTM (OutChan chan) = STM.readTChan chan + +-- | Writes a value to a channel. +writeChan :: InChan a -> a -> IO () +writeChan chan val = STM.atomically (writeChanSTM chan val) + +-- | STM version of 'writeChan', useful for chaining many STM calls inside a single +-- 'atomically' block. +writeChanSTM :: InChan a -> a -> STM.STM () +writeChanSTM (InChan chan) = STM.writeTChan chan diff --git a/src/Haskell/Ide/Engine/Dispatcher.hs b/src/Haskell/Ide/Engine/Dispatcher.hs index 5c21d2fb2..699dc324a 100644 --- a/src/Haskell/Ide/Engine/Dispatcher.hs +++ b/src/Haskell/Ide/Engine/Dispatcher.hs @@ -6,15 +6,13 @@ {-# LANGUAGE ScopedTypeVariables #-} module Haskell.Ide.Engine.Dispatcher ( - dispatcherP + ideDispatcher + , ghcDispatcher , DispatcherEnv(..) , ErrorHandler , CallbackHandler ) where -import Control.Concurrent.STM.TChan -import Control.Concurrent -import Control.Concurrent.Async import Control.Concurrent.STM.TVar import Control.Monad import Control.Monad.IO.Class @@ -23,14 +21,14 @@ import Control.Monad.STM import qualified Data.Text as T import qualified Data.Map as Map import qualified Data.Set as S -import qualified GhcMod.Types as GM -import Haskell.Ide.Engine.Compat + +import qualified Language.Haskell.LSP.Types as J +import qualified Language.Haskell.LSP.Types.Capabilities as J + +import qualified Haskell.Ide.Engine.Channel as Channel import Haskell.Ide.Engine.MonadFunctions import Haskell.Ide.Engine.MonadTypes import Haskell.Ide.Engine.Types -import Haskell.Ide.Engine.Monad -import qualified Language.Haskell.LSP.Types as J -import qualified Language.Haskell.LSP.Types.Capabilities as J data DispatcherEnv = DispatcherEnv { cancelReqsTVar :: !(TVar (S.Set J.LspId)) @@ -43,50 +41,15 @@ type ErrorHandler = J.LspId -> J.ErrorCode -> T.Text -> IO () -- | A handler to run the requests' callback in your monad of choosing. type CallbackHandler m = forall a. RequestCallback m a -> a -> IO () -dispatcherP :: forall m. TChan (PluginRequest m) - -> IdePlugins - -> GM.Options - -> DispatcherEnv - -> ErrorHandler - -> CallbackHandler m - -> J.ClientCapabilities - -> IO () -dispatcherP inChan plugins ghcModOptions env errorHandler callbackHandler caps = do - stateVarVar <- newEmptyMVar - ideChan <- newTChanIO - ghcChan <- newTChanIO - - pid <- getProcessID - - let startState = IdeState emptyModuleCache Map.empty plugins Map.empty Nothing pid - runGhcDisp = runIdeGhcM ghcModOptions caps startState $ do - stateVar <- lift $ lift $ lift ask - liftIO $ putMVar stateVarVar stateVar - ghcDispatcher env errorHandler callbackHandler ghcChan - runIdeDisp = do - stateVar <- readMVar stateVarVar - ideDispatcher stateVar caps env errorHandler callbackHandler ideChan - runMainDisp = mainDispatcher inChan ghcChan ideChan - - runGhcDisp `race_` runIdeDisp `race_` runMainDisp - -mainDispatcher :: forall void m. TChan (PluginRequest m) -> TChan (GhcRequest m) -> TChan (IdeRequest m) -> IO void -mainDispatcher inChan ghcChan ideChan = forever $ do - req <- atomically $ readTChan inChan - case req of - Right r -> - atomically $ writeTChan ghcChan r - Left r -> - atomically $ writeTChan ideChan r ideDispatcher :: forall void m. TVar IdeState -> J.ClientCapabilities -> DispatcherEnv -> ErrorHandler -> CallbackHandler m - -> TChan (IdeRequest m) -> IO void + -> Channel.OutChan (IdeRequest m) -> IO void ideDispatcher stateVar caps env errorHandler callbackHandler pin = -- TODO: AZ run a single ReaderT, with a composite R. flip runReaderT stateVar $ flip runReaderT caps $ forever $ do debugm "ideDispatcher: top of loop" - (IdeRequest tn lid callback action) <- liftIO $ atomically $ readTChan pin + (IdeRequest tn lid callback action) <- liftIO $ Channel.readChan pin debugm $ "ideDispatcher: got request " ++ show tn ++ " with id: " ++ show lid iterT queueDeferred $ @@ -107,10 +70,10 @@ ideDispatcher stateVar caps env errorHandler callbackHandler pin = newQueue = Map.alter (Just . update) fp oldQueue in s { requestQueue = newQueue } -ghcDispatcher :: forall void m. DispatcherEnv -> ErrorHandler -> CallbackHandler m -> TChan (GhcRequest m) -> IdeGhcM void +ghcDispatcher :: forall void m. DispatcherEnv -> ErrorHandler -> CallbackHandler m -> Channel.OutChan (GhcRequest m) -> IdeGhcM void ghcDispatcher env@DispatcherEnv{docVersionTVar} errorHandler callbackHandler pin = forever $ do debugm "ghcDispatcher: top of loop" - (GhcRequest tn context mver mid callback action) <- liftIO $ atomically $ readTChan pin + (GhcRequest tn context mver mid callback action) <- liftIO $ Channel.readChan pin debugm $ "ghcDispatcher:got request " ++ show tn ++ " with id: " ++ show mid let runner = case context of diff --git a/src/Haskell/Ide/Engine/LSP/Reactor.hs b/src/Haskell/Ide/Engine/LSP/Reactor.hs index 76aad34d5..98379e114 100644 --- a/src/Haskell/Ide/Engine/LSP/Reactor.hs +++ b/src/Haskell/Ide/Engine/LSP/Reactor.hs @@ -7,27 +7,26 @@ module Haskell.Ide.Engine.LSP.Reactor , reactorSend' , makeRequest , makeRequests + , updateDocumentRequest + , cancelRequest , asksLspFuncs , REnv(..) ) where -import Control.Concurrent.STM import Control.Monad.Reader import qualified Data.Map as Map -import qualified Data.Set as S import qualified Language.Haskell.LSP.Core as Core import qualified Language.Haskell.LSP.Messages as J import qualified Language.Haskell.LSP.Types as J import Haskell.Ide.Engine.Compat -import Haskell.Ide.Engine.Dispatcher import Haskell.Ide.Engine.LSP.Config import Haskell.Ide.Engine.PluginsIdeMonads +import qualified Haskell.Ide.Engine.Scheduler as Scheduler import Haskell.Ide.Engine.Types data REnv = REnv - { dispatcherEnv :: DispatcherEnv - , reqChanIn :: TChan (PluginRequest R) + { scheduler :: Scheduler.Scheduler R , lspFuncs :: Core.LspFuncs Config , reactorPidCache :: Int , diagnosticSources :: Map.Map DiagnosticTrigger [(PluginId,DiagnosticProviderFunc)] @@ -46,16 +45,15 @@ instance HasPidCache R where runReactor :: Core.LspFuncs Config - -> DispatcherEnv - -> TChan (PluginRequest R) - -> Map.Map DiagnosticTrigger [(PluginId,DiagnosticProviderFunc)] + -> Scheduler.Scheduler R + -> Map.Map DiagnosticTrigger [(PluginId, DiagnosticProviderFunc)] -> [HoverProvider] -> [SymbolProvider] -> R a -> IO a -runReactor lf de cin dps hps sps f = do +runReactor lf sc dps hps sps f = do pid <- getProcessID - runReaderT f (REnv de cin lf pid dps hps sps) + runReaderT f (REnv sc lf pid dps hps sps) -- --------------------------------------------------------------------- @@ -82,30 +80,32 @@ reactorSend' f = do -- --------------------------------------------------------------------- makeRequest :: (MonadIO m, MonadReader REnv m) => PluginRequest R -> m () -makeRequest req@(GReq _ _ Nothing (Just lid) _ _) = writePluginReq req lid -makeRequest req@(IReq _ lid _ _) = writePluginReq req lid -makeRequest req = liftIO . atomically . flip writeTChan req =<< asks reqChanIn - -writePluginReq :: (MonadIO m, MonadReader REnv m) => PluginRequest R -> J.LspId -> m () -writePluginReq req lid = do - wipTVar <- asks (wipReqsTVar . dispatcherEnv) - cin <- asks reqChanIn - liftIO $ atomically $ do - modifyTVar wipTVar (S.insert lid) - writeTChan cin req +makeRequest req = do + sc <- asks scheduler + liftIO $ Scheduler.sendRequest sc Nothing req + +updateDocumentRequest + :: (MonadIO m, MonadReader REnv m) => Uri -> Int -> PluginRequest R -> m () +updateDocumentRequest uri ver req = do + sc <- asks scheduler + liftIO $ Scheduler.sendRequest sc (Just (uri, ver)) req + +cancelRequest :: (MonadIO m, MonadReader REnv m) => J.LspId -> m () +cancelRequest lid = + liftIO . flip Scheduler.cancelRequest lid =<< asks scheduler -- | Execute multiple ide requests sequentially -makeRequests :: [IdeDeferM (IdeResult a)] -- ^ The requests to make - -> TrackingNumber - -> J.LspId - -> ([a] -> R ()) -- ^ Callback with the request inputs and results - -> R () +makeRequests + :: [IdeDeferM (IdeResult a)] -- ^ The requests to make + -> TrackingNumber + -> J.LspId + -> ([a] -> R ()) -- ^ Callback with the request inputs and results + -> R () makeRequests = go [] - where - go acc [] _ _ callback = callback acc - go acc (x:xs) tn reqId callback = - let reqCallback result = go (acc ++ [result]) xs tn reqId callback - in makeRequest $ IReq tn reqId reqCallback x + where + go acc [] _ _ callback = callback acc + go acc (x : xs) tn reqId callback = + let reqCallback result = go (acc ++ [result]) xs tn reqId callback + in makeRequest $ IReq tn reqId reqCallback x -- --------------------------------------------------------------------- - diff --git a/src/Haskell/Ide/Engine/Scheduler.hs b/src/Haskell/Ide/Engine/Scheduler.hs new file mode 100644 index 000000000..f40d1afb0 --- /dev/null +++ b/src/Haskell/Ide/Engine/Scheduler.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NamedFieldPuns #-} +module Haskell.Ide.Engine.Scheduler + ( Scheduler + , DocUpdate + , newScheduler + , runScheduler + , sendRequest + , cancelRequest + ) +where + +import Control.Concurrent.Async ( race_ ) +import qualified Control.Concurrent.MVar as MVar +import qualified Control.Concurrent.STM as STM +import Control.Monad.IO.Class ( liftIO ) +import Control.Monad.Reader.Class ( ask ) +import Control.Monad.Trans.Class ( lift ) +import Control.Monad ( when ) +import qualified Data.Set as Set +import qualified Data.Map as Map +import qualified GhcMod.Types as GM +import qualified Language.Haskell.LSP.Types as J +import qualified Language.Haskell.LSP.Types.Capabilities + as C + +import Haskell.Ide.Engine.GhcModuleCache +import qualified Haskell.Ide.Engine.Compat as Compat +import qualified Haskell.Ide.Engine.Channel as Channel +import Haskell.Ide.Engine.PluginsIdeMonads +import Haskell.Ide.Engine.Types +import Haskell.Ide.Engine.Dispatcher +import qualified Haskell.Ide.Engine.Monad as M + + +data Scheduler m = Scheduler + { plugins :: IdePlugins + , ghcModOptions :: GM.Options + , requestsToCancel :: STM.TVar (Set.Set J.LspId) + , requestsInProgress :: STM.TVar (Set.Set J.LspId) + , documentVersions :: STM.TVar (Map.Map Uri Int) + , ideChan :: (Channel.InChan (IdeRequest m), Channel.OutChan (IdeRequest m)) + , ghcChan :: (Channel.InChan (GhcRequest m), Channel.OutChan (GhcRequest m)) + } + +type DocUpdate = (Uri, Int) + + +newScheduler :: IdePlugins -> GM.Options -> IO (Scheduler m) +newScheduler plugins ghcModOptions = do + cancelTVar <- STM.atomically $ STM.newTVar Set.empty + wipTVar <- STM.atomically $ STM.newTVar Set.empty + versionTVar <- STM.atomically $ STM.newTVar Map.empty + ideChan <- Channel.newChan + ghcChan <- Channel.newChan + return $ Scheduler + { plugins = plugins + , ghcModOptions = ghcModOptions + , requestsToCancel = cancelTVar + , requestsInProgress = wipTVar + , documentVersions = versionTVar + , ideChan = ideChan + , ghcChan = ghcChan + } + + +runScheduler + :: forall m + . Scheduler m + -> ErrorHandler + -> CallbackHandler m + -> C.ClientCapabilities + -> IO () +runScheduler Scheduler {..} errorHandler callbackHandler caps = do + let dEnv = DispatcherEnv + { cancelReqsTVar = requestsToCancel + , wipReqsTVar = requestsInProgress + , docVersionTVar = documentVersions + } + + stateVarVar <- MVar.newEmptyMVar + pid <- Compat.getProcessID + + + let (_, ghcChanOut) = ghcChan + (_, ideChanOut) = ideChan + + let initialState = + IdeState emptyModuleCache Map.empty plugins Map.empty Nothing pid + + runGhcDisp = M.runIdeGhcM ghcModOptions caps initialState $ do + stateVar <- lift . lift . lift $ ask + liftIO $ MVar.putMVar stateVarVar stateVar + ghcDispatcher dEnv errorHandler callbackHandler ghcChanOut + + runIdeDisp = do + stateVar <- MVar.readMVar stateVarVar + ideDispatcher stateVar caps dEnv errorHandler callbackHandler ideChanOut + + + runGhcDisp `race_` runIdeDisp + + +sendRequest + :: forall m . Scheduler m -> Maybe DocUpdate -> PluginRequest m -> IO () +sendRequest Scheduler {..} docUpdate req = do + let (ghcChanIn, _) = ghcChan + (ideChanIn, _) = ideChan + + case docUpdate of + Nothing -> pure () + Just (uri, ver) -> + STM.atomically $ STM.modifyTVar' documentVersions (Map.insert uri ver) + + case req of + Right ghcRequest@GhcRequest { pinLspReqId = Nothing } -> + Channel.writeChan ghcChanIn ghcRequest + + Right ghcRequest@GhcRequest { pinLspReqId = Just lid } -> + STM.atomically $ do + STM.modifyTVar requestsInProgress (Set.insert lid) + Channel.writeChanSTM ghcChanIn ghcRequest + + Left ideRequest@IdeRequest { pureReqId } -> STM.atomically $ do + STM.modifyTVar requestsInProgress (Set.insert pureReqId) + Channel.writeChanSTM ideChanIn ideRequest + +cancelRequest :: forall m . Scheduler m -> J.LspId -> IO () +cancelRequest Scheduler { requestsToCancel, requestsInProgress } lid = + STM.atomically $ do + wip <- STM.readTVar requestsInProgress + when (Set.member lid wip) + $ STM.modifyTVar' requestsToCancel (Set.insert lid) diff --git a/src/Haskell/Ide/Engine/Transport/JsonStdio.hs b/src/Haskell/Ide/Engine/Transport/JsonStdio.hs index d7b714cb9..0ce3183b8 100644 --- a/src/Haskell/Ide/Engine/Transport/JsonStdio.hs +++ b/src/Haskell/Ide/Engine/Transport/JsonStdio.hs @@ -14,7 +14,6 @@ module Haskell.Ide.Engine.Transport.JsonStdio import Control.Concurrent.Async import Control.Concurrent.STM.TChan -import Control.Concurrent.STM.TVar import qualified Control.Exception as E import Control.Monad import Control.Monad.STM @@ -23,18 +22,15 @@ import qualified Data.Aeson as J import qualified Data.ByteString.Builder as B import qualified Data.ByteString.Lazy.Char8 as B import Data.Default -import qualified Data.Map as Map #if __GLASGOW_HASKELL__ < 804 import Data.Monoid #endif -import qualified Data.Set as S import qualified Data.Text as T import GHC.Generics -import Haskell.Ide.Engine.Dispatcher +import qualified Haskell.Ide.Engine.Scheduler as Scheduler import Haskell.Ide.Engine.PluginDescriptor import Haskell.Ide.Engine.Types import qualified Language.Haskell.LSP.Types as J -import Language.Haskell.LSP.Types.Capabilities import System.Exit import System.IO import qualified System.Log.Logger as L @@ -46,9 +42,9 @@ import qualified System.Log.Logger as L -- --------------------------------------------------------------------- -jsonStdioTransport :: (DispatcherEnv -> ErrorHandler -> CallbackHandler IO -> ClientCapabilities -> IO ()) -> TChan (PluginRequest IO) -> IO () -jsonStdioTransport hieDispatcherProc cin = do - run hieDispatcherProc cin >>= \case +jsonStdioTransport :: Scheduler.Scheduler IO -> IO () +jsonStdioTransport scheduler = do + run scheduler >>= \case 0 -> exitSuccess c -> exitWith . ExitFailure $ c @@ -68,25 +64,17 @@ data ReactorOutput = ReactorOutput , _response :: J.Value } deriving (Eq, Show, Generic, J.ToJSON, J.FromJSON) -run :: (DispatcherEnv -> ErrorHandler -> CallbackHandler IO -> ClientCapabilities -> IO ()) -> TChan (PluginRequest IO) -> IO Int -run dispatcherProc cin = flip E.catches handlers $ do +run :: Scheduler.Scheduler IO -> IO Int +run scheduler = flip E.catches handlers $ do flip E.finally finalProc $ do rout <- atomically newTChan :: IO (TChan ReactorOutput) - cancelTVar <- atomically $ newTVar S.empty - wipTVar <- atomically $ newTVar S.empty - versionTVar <- atomically $ newTVar Map.empty - let dispatcherEnv = DispatcherEnv - { cancelReqsTVar = cancelTVar - , wipReqsTVar = wipTVar - , docVersionTVar = versionTVar - } let race3_ a b c = race_ a (race_ b c) let errorHandler lid _ e = liftIO $ hPutStrLn stderr $ "Got an error for request " ++ show lid ++ ": " ++ T.unpack e callbackHandler callback x = callback x - race3_ (dispatcherProc dispatcherEnv errorHandler callbackHandler def) + race3_ (Scheduler.runScheduler scheduler errorHandler callbackHandler def) (outWriter rout) (reactor rout) @@ -116,7 +104,7 @@ run dispatcherProc cin = flip E.catches handlers $ do $ runPluginCommand (plugin req) (command req) (arg req) rid = reqId req callback = sendResponse rid . dynToJSON - atomically $ writeTChan cin preq + Scheduler.sendRequest scheduler Nothing preq getNextReq :: IO (Maybe ReactorInput) getNextReq = do @@ -142,5 +130,3 @@ getNextReq = do rest <- readReqByteString let cur = B.charUtf8 char return $ Just $ maybe cur (cur <>) rest - - diff --git a/src/Haskell/Ide/Engine/Transport/LspStdio.hs b/src/Haskell/Ide/Engine/Transport/LspStdio.hs index e7b55ca97..89f4c297d 100644 --- a/src/Haskell/Ide/Engine/Transport/LspStdio.hs +++ b/src/Haskell/Ide/Engine/Transport/LspStdio.hs @@ -18,7 +18,6 @@ module Haskell.Ide.Engine.Transport.LspStdio import Control.Concurrent import Control.Concurrent.Async import Control.Concurrent.STM.TChan -import Control.Concurrent.STM.TVar import qualified Control.FoldDebounce as Debounce import qualified Control.Exception as E import Control.Lens ( (^.), (.~) ) @@ -48,6 +47,7 @@ import Haskell.Ide.Engine.MonadFunctions import Haskell.Ide.Engine.MonadTypes import Haskell.Ide.Engine.Dispatcher import Haskell.Ide.Engine.PluginUtils +import qualified Haskell.Ide.Engine.Scheduler as Scheduler import Haskell.Ide.Engine.Types import Haskell.Ide.Engine.LSP.CodeActions import Haskell.Ide.Engine.LSP.Config @@ -79,14 +79,13 @@ import qualified Yi.Rope as Yi -- --------------------------------------------------------------------- lspStdioTransport - :: (DispatcherEnv -> ErrorHandler -> CallbackHandler R -> ClientCapabilities -> IO ()) - -> TChan (PluginRequest R) + :: Scheduler.Scheduler R -> FilePath -> IdePlugins -> Maybe FilePath -> IO () -lspStdioTransport hieDispatcherProc cin origDir plugins captureFp = do - run hieDispatcherProc cin origDir plugins captureFp >>= \case +lspStdioTransport scheduler origDir plugins captureFp = do + run scheduler origDir plugins captureFp >>= \case 0 -> exitSuccess c -> exitWith . ExitFailure $ c @@ -115,28 +114,19 @@ instance Semigroup (MostRecent a) where _ <> b = b run - :: (DispatcherEnv -> ErrorHandler -> CallbackHandler R -> ClientCapabilities -> IO ()) - -> TChan (PluginRequest R) + :: Scheduler.Scheduler R -> FilePath -> IdePlugins -> Maybe FilePath -> IO Int -run dispatcherProc cin _origDir plugins captureFp = flip E.catches handlers $ do +run scheduler _origDir plugins captureFp = flip E.catches handlers $ do rin <- atomically newTChan :: IO (TChan ReactorInput) commandIds <- allLspCmdIds plugins let dp lf = do - cancelTVar <- atomically $ newTVar S.empty - wipTVar <- atomically $ newTVar S.empty - versionTVar <- atomically $ newTVar Map.empty diagIn <- atomically newTChan - let dEnv = DispatcherEnv - { cancelReqsTVar = cancelTVar - , wipReqsTVar = wipTVar - , docVersionTVar = versionTVar - } - let react = runReactor lf dEnv cin diagnosticProviders hps sps + let react = runReactor lf scheduler diagnosticProviders hps sps let reactorFunc = react $ reactor rin diagIn caps = Core.clientCapabilities lf @@ -163,7 +153,7 @@ run dispatcherProc cin _origDir plugins captureFp = flip E.catches handlers $ do -- haskell lsp sets the current directory to the project root in the InitializeRequest -- We launch the dispatcher after that so that the default cradle is -- recognized properly by ghc-mod - _ <- forkIO $ dispatcherProc dEnv errorHandler callbackHandler caps + _ <- forkIO $ Scheduler.runScheduler scheduler errorHandler callbackHandler caps `race_` reactorFunc `race_` diagnosticsQueue tr return Nothing @@ -243,8 +233,6 @@ mapFileFromVfs :: (MonadIO m, MonadReader REnv m) => TrackingNumber -> J.VersionedTextDocumentIdentifier -> m () mapFileFromVfs tn vtdi = do - verTVar <- asks (docVersionTVar . dispatcherEnv) - cin <- asks reqChanIn let uri = vtdi ^. J.uri ver = fromMaybe 0 (vtdi ^. J.version) vfsFunc <- asksLspFuncs Core.getVirtualFileFunc @@ -258,26 +246,9 @@ mapFileFromVfs tn vtdi = do GM.loadMappedFileSource fp text' fileMap <- GM.getMMappedFiles debugm $ "file mapping state is: " ++ show fileMap - liftIO $ atomically $ do - modifyTVar' verTVar (Map.insert uri ver) - writeTChan cin req - return () + updateDocumentRequest uri ver req (_, _) -> return () -_unmapFileFromVfs :: (MonadIO m, MonadReader REnv m) => TrackingNumber -> J.Uri -> m () -_unmapFileFromVfs tn uri = do - verTVar <- asks (docVersionTVar . dispatcherEnv) - cin <- asks reqChanIn - case J.uriToFilePath uri of - Just fp -> do - let req = GReq tn (Just uri) Nothing Nothing (const $ return ()) - $ IdeResultOk <$> GM.unloadMappedFile fp - liftIO $ atomically $ do - modifyTVar' verTVar (Map.delete uri) - writeTChan cin req - return () - _ -> return () - -- TODO: generalise this and move it to GhcMod.ModuleLoader updatePositionMap :: Uri -> [J.TextDocumentContentChangeEvent] -> IdeGhcM (IdeResult ()) updatePositionMap uri changes = pluginGetFile "updatePositionMap: " uri $ \file -> @@ -745,11 +716,7 @@ reactor inp diagIn = do NotCancelRequestFromClient notif -> do liftIO $ U.logs $ "reactor:got CancelRequest:" ++ show notif let lid = notif ^. J.params . J.id - DispatcherEnv cancelReqTVar wipTVar _ <- asks dispatcherEnv - liftIO $ atomically $ do - wip <- readTVar wipTVar - when (S.member lid wip) $ do - modifyTVar' cancelReqTVar (S.insert lid) + cancelRequest lid -- ------------------------------- @@ -797,7 +764,6 @@ requestDiagnostics DiagnosticsRequest{trigger, file, trackingNumber, documentVer diagFuncs <- asks diagnosticSources lf <- asks lspFuncs - cin <- asks reqChanIn mc <- liftIO $ Core.config lf case Map.lookup trigger diagFuncs of Nothing -> do @@ -845,13 +811,12 @@ requestDiagnostics DiagnosticsRequest{trigger, file, trackingNumber, documentVer case diags of [] -> liftIO sendEmpty _ -> mapM_ (liftIO . sendOne) diags - when enabled $ liftIO $ atomically $ writeTChan cin reql + when enabled $ makeRequest reql -- | get hlint and GHC diagnostics and loads the typechecked module into the cache requestDiagnosticsNormal :: TrackingNumber -> J.Uri -> J.TextDocumentVersion -> R () requestDiagnosticsNormal tn file mVer = do lf <- asks lspFuncs - cin <- asks reqChanIn mc <- liftIO $ Core.config lf let ver = fromMaybe 0 mVer @@ -879,7 +844,7 @@ requestDiagnosticsNormal tn file mVer = do $ ApplyRefact.lintCmd' file callbackl (PublishDiagnosticsParams fp (List ds)) = sendOne "hlint" (fp, ds) - liftIO $ atomically $ writeTChan cin reql + makeRequest reql -- get GHC diagnostics and loads the typechecked module into the cache let reqg = GReq tn (Just file) (Just (file,ver)) Nothing callbackg @@ -894,7 +859,7 @@ requestDiagnosticsNormal tn file mVer = do [] -> sendEmpty _ -> mapM_ (sendOneGhc "ghcmod") ds - liftIO $ atomically $ writeTChan cin reqg + makeRequest reqg -- --------------------------------------------------------------------- From 6bcf940e8ab6121ca3e3417eb74a792a094abab3 Mon Sep 17 00:00:00 2001 From: Jose Lorenzo Rodriguez Date: Mon, 8 Oct 2018 11:41:08 +0200 Subject: [PATCH 02/11] Fixed dispatcher tests --- test/dispatcher/Main.hs | 95 ++++++++++++++++++----------------------- 1 file changed, 42 insertions(+), 53 deletions(-) diff --git a/test/dispatcher/Main.hs b/test/dispatcher/Main.hs index fe05cd851..52a583fa4 100644 --- a/test/dispatcher/Main.hs +++ b/test/dispatcher/Main.hs @@ -5,21 +5,18 @@ module Main where import Control.Concurrent import Control.Concurrent.STM.TChan -import Control.Concurrent.STM.TVar import Control.Monad.STM import Data.Aeson import qualified Data.HashMap.Strict as H -import qualified Data.Map as Map -import qualified Data.Set as S import Data.Typeable import qualified Data.Text as T import Data.Default import GHC ( TypecheckedModule ) import GHC.Generics -import Haskell.Ide.Engine.Dispatcher import Haskell.Ide.Engine.MonadTypes import Haskell.Ide.Engine.PluginDescriptor import Haskell.Ide.Engine.PluginUtils +import Haskell.Ide.Engine.Scheduler import Haskell.Ide.Engine.Types import Language.Haskell.LSP.Types import TestUtils @@ -70,28 +67,18 @@ plugins = pluginDescToIdePlugins ,baseDescriptor "base" ] -startServer :: IO (TChan (PluginRequest IO), TChan LogVal, ThreadId) +startServer :: IO (Scheduler IO, TChan LogVal, ThreadId) startServer = do - - cin <- newTChanIO + scheduler <- newScheduler plugins testOptions logChan <- newTChanIO - - cancelTVar <- newTVarIO S.empty - wipTVar <- newTVarIO S.empty - versionTVar <- newTVarIO Map.empty - let dispatcherEnv = DispatcherEnv - { cancelReqsTVar = cancelTVar - , wipReqsTVar = wipTVar - , docVersionTVar = versionTVar - } - dispatcher <- forkIO $ - dispatcherP cin plugins testOptions dispatcherEnv + runScheduler + scheduler (\lid errCode e -> logToChan logChan ("received an error", Left (lid, errCode, e))) (\g x -> g x) def - return (cin, logChan, dispatcher) + return (scheduler, logChan, dispatcher) -- --------------------------------------------------------------------- @@ -104,27 +91,27 @@ logToChan c t = atomically $ writeTChan c t dispatchGhcRequest :: ToJSON a => TrackingNumber -> String -> Int - -> TChan (PluginRequest IO) -> TChan LogVal + -> Scheduler IO -> TChan LogVal -> PluginId -> CommandName -> a -> IO () -dispatchGhcRequest tn ctx n cin lc plugin com arg = do +dispatchGhcRequest tn ctx n scheduler lc plugin com arg = do let logger :: RequestCallback IO DynamicJSON logger x = logToChan lc (ctx, Right x) let req = GReq tn Nothing Nothing (Just (IdInt n)) logger $ runPluginCommand plugin com (toJSON arg) - atomically $ writeTChan cin req + sendRequest scheduler Nothing req dispatchIdeRequest :: (Typeable a, ToJSON a) - => TrackingNumber -> String -> TChan (PluginRequest IO) + => TrackingNumber -> String -> Scheduler IO -> TChan LogVal -> LspId -> IdeDeferM (IdeResult a) -> IO () -dispatchIdeRequest tn ctx cin lc lid f = do +dispatchIdeRequest tn ctx scheduler lc lid f = do let logger :: (Typeable a, ToJSON a) => RequestCallback IO a logger x = logToChan lc (ctx, Right (toDynJSON x)) let req = IReq tn lid logger f - atomically $ writeTChan cin req + sendRequest scheduler Nothing req -- --------------------------------------------------------------------- @@ -140,28 +127,30 @@ newPluginSpec :: Spec newPluginSpec = do describe "New plugin dispatcher operation" $ it "dispatches response correctly" $ do - inChan <- atomically newTChan outChan <- atomically newTChan - cancelTVar <- newTVarIO S.empty - wipTVar <- newTVarIO S.empty - versionTVar <- newTVarIO $ Map.singleton (filePathToUri "test") 3 - let req1 = GReq 1 Nothing Nothing (Just $ IdInt 1) (atomically . writeTChan outChan) $ return $ IdeResultOk $ T.pack "text1" - req2 = GReq 2 Nothing Nothing (Just $ IdInt 2) (atomically . writeTChan outChan) $ return $ IdeResultOk $ T.pack "text2" - req3 = GReq 3 Nothing (Just (filePathToUri "test", 2)) Nothing (atomically . writeTChan outChan) $ return $ IdeResultOk $ T.pack "text3" - req4 = GReq 4 Nothing Nothing (Just $ IdInt 3) (atomically . writeTChan outChan) $ return $ IdeResultOk $ T.pack "text4" - - pid <- forkIO $ dispatcherP inChan - (pluginDescToIdePlugins []) - testOptions - (DispatcherEnv cancelTVar wipTVar versionTVar) + scheduler <- newScheduler (pluginDescToIdePlugins []) testOptions + let defCallback = atomically . writeTChan outChan + delayedCallback = \r -> threadDelay 10000 >> defCallback r + + let req0 = GReq 0 Nothing Nothing (Just $ IdInt 0) (\_ -> return () :: IO ()) $ return $ IdeResultOk $ T.pack "text0" + req1 = GReq 1 Nothing Nothing (Just $ IdInt 1) defCallback $ return $ IdeResultOk $ T.pack "text1" + req2 = GReq 2 Nothing Nothing (Just $ IdInt 2) delayedCallback $ return $ IdeResultOk $ T.pack "text2" + req3 = GReq 3 Nothing (Just (filePathToUri "test", 2)) Nothing defCallback $ return $ IdeResultOk $ T.pack "text3" + req4 = GReq 4 Nothing Nothing (Just $ IdInt 3) defCallback $ return $ IdeResultOk $ T.pack "text4" + + let makeReq = sendRequest scheduler Nothing + + pid <- forkIO $ runScheduler scheduler (\_ _ _ -> return ()) (\f x -> f x) def - atomically $ writeTChan inChan req1 - atomically $ modifyTVar cancelTVar (S.insert (IdInt 2)) - atomically $ writeTChan inChan req2 - atomically $ writeTChan inChan req3 - atomically $ writeTChan inChan req4 + + sendRequest scheduler (Just (filePathToUri "test", 3)) req0 + makeReq req1 + makeReq req2 + cancelRequest scheduler (IdInt 2) + makeReq req3 + makeReq req4 resp1 <- atomically $ readTChan outChan resp2 <- atomically $ readTChan outChan killThread pid @@ -171,10 +160,10 @@ newPluginSpec = do funcSpec :: Spec funcSpec = describe "functional dispatch" $ do runIO $ setCurrentDirectory "test/testdata" - (cin, logChan, dispatcher) <- runIO startServer + (scheduler, logChan, dispatcher) <- runIO startServer cwd <- runIO getCurrentDirectory - + let testUri = filePathToUri $ cwd "FuncTest.hs" testFailUri = filePathToUri $ cwd "FuncTestFail.hs" @@ -182,7 +171,7 @@ funcSpec = describe "functional dispatch" $ do hoverReqHandler :: TypecheckedModule -> CachedInfo -> IdeDeferM (IdeResult Cached) hoverReqHandler _ _ = return (IdeResultOk Cached) -- Model a hover request - hoverReq tn idVal doc = dispatchIdeRequest tn ("IReq " ++ show idVal) cin logChan idVal $ do + hoverReq tn idVal doc = dispatchIdeRequest tn ("IReq " ++ show idVal) scheduler logChan idVal $ do pluginGetFile "hoverReq" doc $ \fp -> ifCachedModule fp (IdeResultOk NotCached) hoverReqHandler @@ -199,13 +188,13 @@ funcSpec = describe "functional dispatch" $ do unpackRes hr0 `shouldBe` ("IReq IdInt 0",Just NotCached) -- This request should be deferred, only return when the module is loaded - dispatchIdeRequest 1 "req1" cin logChan (IdInt 1) $ symbolProvider testUri + dispatchIdeRequest 1 "req1" scheduler logChan (IdInt 1) $ symbolProvider testUri rrr <- atomically $ tryReadTChan logChan show rrr `shouldBe` "Nothing" -- need to typecheck the module to trigger deferred response - dispatchGhcRequest 2 "req2" 2 cin logChan "ghcmod" "check" (toJSON testUri) + dispatchGhcRequest 2 "req2" 2 scheduler logChan "ghcmod" "check" (toJSON testUri) -- And now we get the deferred response (once the module is loaded) ("req1",Right res) <- atomically $ readTChan logChan @@ -231,7 +220,7 @@ funcSpec = describe "functional dispatch" $ do it "instantly responds to deferred requests if cache is available" $ do -- deferred responses should return something now immediately -- as long as the above test ran before - dispatchIdeRequest 0 "references" cin logChan (IdInt 4) + dispatchIdeRequest 0 "references" scheduler logChan (IdInt 4) $ getReferencesInDoc testUri (Position 7 0) hr4 <- atomically $ readTChan logChan @@ -283,7 +272,7 @@ funcSpec = describe "functional dispatch" $ do it "returns hints as diagnostics" $ do - dispatchGhcRequest 5 "r5" 5 cin logChan "applyrefact" "lint" testUri + dispatchGhcRequest 5 "r5" 5 scheduler logChan "applyrefact" "lint" testUri hr5 <- atomically $ readTChan logChan unpackRes hr5 `shouldBe` ("r5", @@ -302,7 +291,7 @@ funcSpec = describe "functional dispatch" $ do ) let req6 = HP testUri (toPos (8, 1)) - dispatchGhcRequest 6 "r6" 6 cin logChan "hare" "demote" req6 + dispatchGhcRequest 6 "r6" 6 scheduler logChan "hare" "demote" req6 hr6 <- atomically $ readTChan logChan -- show hr6 `shouldBe` "hr6" @@ -316,9 +305,9 @@ funcSpec = describe "functional dispatch" $ do it "instantly responds to failed modules with no cache with the default" $ do - dispatchIdeRequest 7 "req7" cin logChan (IdInt 7) $ findDef testFailUri (Position 1 2) + dispatchIdeRequest 7 "req7" scheduler logChan (IdInt 7) $ findDef testFailUri (Position 1 2) - dispatchGhcRequest 8 "req8" 8 cin logChan "ghcmod" "check" (toJSON testFailUri) + dispatchGhcRequest 8 "req8" 8 scheduler logChan "ghcmod" "check" (toJSON testFailUri) hr7 <- atomically $ readTChan logChan unpackRes hr7 `shouldBe` ("req7", Just ([] :: [Location])) From 716510b98316c4254cf977b10cfe25b97df7ff38 Mon Sep 17 00:00:00 2001 From: Jose Lorenzo Rodriguez Date: Tue, 9 Oct 2018 13:43:52 +0200 Subject: [PATCH 03/11] Documenting the Scheduler module --- src/Haskell/Ide/Engine/Scheduler.hs | 66 ++++++++++++++++++++++++++++- 1 file changed, 64 insertions(+), 2 deletions(-) diff --git a/src/Haskell/Ide/Engine/Scheduler.hs b/src/Haskell/Ide/Engine/Scheduler.hs index f40d1afb0..471403d0a 100644 --- a/src/Haskell/Ide/Engine/Scheduler.hs +++ b/src/Haskell/Ide/Engine/Scheduler.hs @@ -35,20 +35,60 @@ import Haskell.Ide.Engine.Dispatcher import qualified Haskell.Ide.Engine.Monad as M +-- | A Scheduler is a coordinator between the two main processes the ide engine uses +-- for responding to users requests. It accepts all of the requests and dispatches +-- them accordingly. One process accepts requests that require a GHC session such as +-- parsing, type checking and generating error diagnostics, whereas another process deals +-- with IDE features such as code navigation, code completion and symbol information. +-- +-- It needs to be run using the 'runScheduler' function after being created in +-- order to start dispatching requests. +-- +-- Schedulers are parameterized in the monad of your choosing, which is the monad where +-- request handlers and error handlers will run. data Scheduler m = Scheduler { plugins :: IdePlugins + -- ^ The list of plugins that will be used for responding to requests + , ghcModOptions :: GM.Options + -- ^ Options for the ghc-mod session. Since we only keep a single ghc-mod session + -- at a time, this cannot be changed a runtime. + , requestsToCancel :: STM.TVar (Set.Set J.LspId) + -- ^ The request IDs that were canceled by the client. This causes requests to + -- not be dispatched or aborted if they are already in progress. + , requestsInProgress :: STM.TVar (Set.Set J.LspId) + -- ^ Requests IDs that have already been dispatched. Currently this is only used to keep + -- @requestsToCancel@ bounded. We only insert IDs into the cancel list if the same LspId is + -- also present in this variable. + , documentVersions :: STM.TVar (Map.Map Uri Int) + -- ^ A Map containing document file paths with their respective current version. This is used + -- to prevent certain requests from being processed if the current version is more recent than + -- the version the request is for. + , ideChan :: (Channel.InChan (IdeRequest m), Channel.OutChan (IdeRequest m)) + -- ^ Holds the reading and writing ends of the channel used to dispatch Ide requests + , ghcChan :: (Channel.InChan (GhcRequest m), Channel.OutChan (GhcRequest m)) + -- ^ Holds the reading and writing ends of the channel used to dispatch Ghc requests } +-- ^ A pair representing the document file path and a new version to store for it. type DocUpdate = (Uri, Int) -newScheduler :: IdePlugins -> GM.Options -> IO (Scheduler m) +-- | Create a new scheduler parameterized with the monad of your choosing. +-- This is the monad where the handler for requests and handler for errors will run. +-- +-- Once created, the scheduler needs to be run using 'runScheduler' +newScheduler + :: IdePlugins + -- ^ The list of plugins that will be used for responding to requests + -> GM.Options + -- ^ Options for the ghc-mod session. Since we only keep a single ghc-mod session + -> IO (Scheduler m) newScheduler plugins ghcModOptions = do cancelTVar <- STM.atomically $ STM.newTVar Set.empty wipTVar <- STM.atomically $ STM.newTVar Set.empty @@ -66,12 +106,18 @@ newScheduler plugins ghcModOptions = do } +-- | Runs the given scheduler. This is meant to run in a separate thread and +-- the thread should be kept alive as long as you need requests to be dispatched. runScheduler :: forall m . Scheduler m + -- ^ The scheduler to run. -> ErrorHandler + -- ^ A handler for any errors that the dispatcher may encounter. -> CallbackHandler m + -- ^ A handler to run the requests' callback in your monad of choosing. -> C.ClientCapabilities + -- ^ List of features the IDE client supports or has enabled. -> IO () runScheduler Scheduler {..} errorHandler callbackHandler caps = do let dEnv = DispatcherEnv @@ -103,8 +149,22 @@ runScheduler Scheduler {..} errorHandler callbackHandler caps = do runGhcDisp `race_` runIdeDisp +-- | Sends a request to the scheduler so that it can be dispatched to the handler +-- function. Certain requests may never be dispatched if they get canceled +-- by the client by the time they reach the head of the queue. +-- +-- If a 'DocUpdate' is provided, the version for the given document is updated +-- before the request is queued. This may cause other requests to never be processed if +-- the current version of the document differs from the version the request is meant for. sendRequest - :: forall m . Scheduler m -> Maybe DocUpdate -> PluginRequest m -> IO () + :: forall m + . Scheduler m + -- ^ The scheduler to send the request to. + -> Maybe DocUpdate + -- ^ If not Nothing, the version for the given document is updated before dispatching. + -> PluginRequest m + -- ^ The request to dispatch. + -> IO () sendRequest Scheduler {..} docUpdate req = do let (ghcChanIn, _) = ghcChan (ideChanIn, _) = ideChan @@ -127,6 +187,8 @@ sendRequest Scheduler {..} docUpdate req = do STM.modifyTVar requestsInProgress (Set.insert pureReqId) Channel.writeChanSTM ideChanIn ideRequest +-- | Cancels a request previously sent to the given scheduler. This causes the +-- request with the same LspId to never be dispatched, or aborted if already in progress. cancelRequest :: forall m . Scheduler m -> J.LspId -> IO () cancelRequest Scheduler { requestsToCancel, requestsInProgress } lid = STM.atomically $ do From 198b2a08f60086fa35cf7b1cae26e1dafb270a4f Mon Sep 17 00:00:00 2001 From: Jose Lorenzo Rodriguez Date: Tue, 9 Oct 2018 13:47:53 +0200 Subject: [PATCH 04/11] Documenting some other functions --- src/Haskell/Ide/Engine/LSP/Reactor.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Haskell/Ide/Engine/LSP/Reactor.hs b/src/Haskell/Ide/Engine/LSP/Reactor.hs index 98379e114..e08e184d8 100644 --- a/src/Haskell/Ide/Engine/LSP/Reactor.hs +++ b/src/Haskell/Ide/Engine/LSP/Reactor.hs @@ -79,17 +79,22 @@ reactorSend' f = do -- --------------------------------------------------------------------- +-- | Sends a single request to the scheduler so it can be be processed +-- asynchronously. makeRequest :: (MonadIO m, MonadReader REnv m) => PluginRequest R -> m () makeRequest req = do sc <- asks scheduler liftIO $ Scheduler.sendRequest sc Nothing req +-- | Updates the version of a document and then sends the request to be processed +-- asynchronously. updateDocumentRequest :: (MonadIO m, MonadReader REnv m) => Uri -> Int -> PluginRequest R -> m () updateDocumentRequest uri ver req = do sc <- asks scheduler liftIO $ Scheduler.sendRequest sc (Just (uri, ver)) req +-- | Marks a s requests as cencelled by its LspId cancelRequest :: (MonadIO m, MonadReader REnv m) => J.LspId -> m () cancelRequest lid = liftIO . flip Scheduler.cancelRequest lid =<< asks scheduler From 98284d9c3892a85a7856237275f26e727be202bb Mon Sep 17 00:00:00 2001 From: Jose Lorenzo Rodriguez Date: Tue, 9 Oct 2018 15:45:15 +0200 Subject: [PATCH 05/11] Fixed Architecture docs --- docs/Architecture.md | 25 ++++++++++++++++--------- 1 file changed, 16 insertions(+), 9 deletions(-) diff --git a/docs/Architecture.md b/docs/Architecture.md index 9c04921f8..07457646f 100644 --- a/docs/Architecture.md +++ b/docs/Architecture.md @@ -113,13 +113,20 @@ fresh data is generated when first requested. ## Dispatcher and messaging ```haskell -dispatcherP :: forall m. TChan (PluginRequest m) - -> IdePlugins - -> GM.Options - -> DispatcherEnv - -> ErrorHandler - -> CallbackHandler m - -> IO () +runScheduler + :: forall m + . Scheduler m + -> ErrorHandler + -> CallbackHandler m + -> C.ClientCapabilities + -> IO () + +sendRequest + :: forall m + . Scheduler m + -> Maybe DocUpdate + -> PluginRequest m + -> IO () type PluginRequest m = Either (IdeRequest m) (GhcRequest m) @@ -139,8 +146,8 @@ data IdeRequest m = forall a. IdeRequest ``` -`dispatcherP`(thread #3) listens for `PluginRequest`s on the `TChan` and executes the -`pinReq`, sending the result to the `pinCallback`. `pinDocVer` and `pinLspReqId` help us +`runScheduler`(thread #3) waits for requests sent through `sendRequest` and executes the +`pinReq`. Sending the result to the `pinCallback`. `pinDocVer` and `pinLspReqId` help us make sure we don't execute a stale request or a request that has been cancelled by the IDE. Note that because of the single threaded architecture, we can't cancel a request that has already started execution. From 142419b1cb05bfee4486af3e4e44b3d0c2e6dc9e Mon Sep 17 00:00:00 2001 From: Jose Lorenzo Rodriguez Date: Thu, 11 Oct 2018 20:03:35 +0200 Subject: [PATCH 06/11] Moving all of the Dispatcher into the new Scheduler module --- haskell-ide-engine.cabal | 1 - src/Haskell/Ide/Engine/Dispatcher.hs | 125 --------------- src/Haskell/Ide/Engine/Scheduler.hs | 157 ++++++++++++++++++- src/Haskell/Ide/Engine/Transport/LspStdio.hs | 5 +- 4 files changed, 157 insertions(+), 131 deletions(-) delete mode 100644 src/Haskell/Ide/Engine/Dispatcher.hs diff --git a/haskell-ide-engine.cabal b/haskell-ide-engine.cabal index ec9c20f09..2991d03dc 100644 --- a/haskell-ide-engine.cabal +++ b/haskell-ide-engine.cabal @@ -21,7 +21,6 @@ library hs-source-dirs: src exposed-modules: Haskell.Ide.Engine.Plugin.Base Haskell.Ide.Engine.Channel - Haskell.Ide.Engine.Dispatcher Haskell.Ide.Engine.Scheduler Haskell.Ide.Engine.LSP.CodeActions Haskell.Ide.Engine.LSP.Config diff --git a/src/Haskell/Ide/Engine/Dispatcher.hs b/src/Haskell/Ide/Engine/Dispatcher.hs deleted file mode 100644 index 699dc324a..000000000 --- a/src/Haskell/Ide/Engine/Dispatcher.hs +++ /dev/null @@ -1,125 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Haskell.Ide.Engine.Dispatcher - ( - ideDispatcher - , ghcDispatcher - , DispatcherEnv(..) - , ErrorHandler - , CallbackHandler - ) where - -import Control.Concurrent.STM.TVar -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Reader -import Control.Monad.STM -import qualified Data.Text as T -import qualified Data.Map as Map -import qualified Data.Set as S - -import qualified Language.Haskell.LSP.Types as J -import qualified Language.Haskell.LSP.Types.Capabilities as J - -import qualified Haskell.Ide.Engine.Channel as Channel -import Haskell.Ide.Engine.MonadFunctions -import Haskell.Ide.Engine.MonadTypes -import Haskell.Ide.Engine.Types - -data DispatcherEnv = DispatcherEnv - { cancelReqsTVar :: !(TVar (S.Set J.LspId)) - , wipReqsTVar :: !(TVar (S.Set J.LspId)) - , docVersionTVar :: !(TVar (Map.Map Uri Int)) - } - --- | A handler for any errors that the dispatcher may encounter. -type ErrorHandler = J.LspId -> J.ErrorCode -> T.Text -> IO () --- | A handler to run the requests' callback in your monad of choosing. -type CallbackHandler m = forall a. RequestCallback m a -> a -> IO () - - -ideDispatcher :: forall void m. TVar IdeState -> J.ClientCapabilities - -> DispatcherEnv -> ErrorHandler -> CallbackHandler m - -> Channel.OutChan (IdeRequest m) -> IO void -ideDispatcher stateVar caps env errorHandler callbackHandler pin = - -- TODO: AZ run a single ReaderT, with a composite R. - flip runReaderT stateVar $ flip runReaderT caps $ forever $ do - debugm "ideDispatcher: top of loop" - (IdeRequest tn lid callback action) <- liftIO $ Channel.readChan pin - debugm $ "ideDispatcher: got request " ++ show tn ++ " with id: " ++ show lid - - iterT queueDeferred $ - checkCancelled env lid errorHandler $ do - result <- action - checkCancelled env lid errorHandler $ liftIO $ do - completedReq env lid - case result of - IdeResultOk x -> callbackHandler callback x - IdeResultFail (IdeError _ msg _) -> errorHandler lid J.InternalError msg - - where queueDeferred (Defer fp cacheCb) = - lift $ modifyMTState $ \s -> - let oldQueue = requestQueue s - -- add to existing queue if possible - update Nothing = [cacheCb] - update (Just x) = cacheCb : x - newQueue = Map.alter (Just . update) fp oldQueue - in s { requestQueue = newQueue } - -ghcDispatcher :: forall void m. DispatcherEnv -> ErrorHandler -> CallbackHandler m -> Channel.OutChan (GhcRequest m) -> IdeGhcM void -ghcDispatcher env@DispatcherEnv{docVersionTVar} errorHandler callbackHandler pin = forever $ do - debugm "ghcDispatcher: top of loop" - (GhcRequest tn context mver mid callback action) <- liftIO $ Channel.readChan pin - debugm $ "ghcDispatcher:got request " ++ show tn ++ " with id: " ++ show mid - - let runner = case context of - Nothing -> runActionWithContext Nothing - Just uri -> case uriToFilePath uri of - Just fp -> runActionWithContext (Just fp) - Nothing -> \act -> do - debugm "ghcDispatcher:Got malformed uri, running action with default context" - runActionWithContext Nothing act - - let runWithCallback = do - result <- runner action - liftIO $ case result of - IdeResultOk x -> callbackHandler callback x - IdeResultFail err@(IdeError _ msg _) -> - case mid of - Just lid -> errorHandler lid J.InternalError msg - Nothing -> debugm $ "ghcDispatcher:Got error for a request: " ++ show err - - let runIfVersionMatch = case mver of - Nothing -> runWithCallback - Just (uri, reqver) -> do - curver <- liftIO $ atomically $ Map.lookup uri <$> readTVar docVersionTVar - if Just reqver /= curver then - debugm "ghcDispatcher:not processing request as it is for old version" - else do - debugm "ghcDispatcher:Processing request as version matches" - runWithCallback - - case mid of - Nothing -> runIfVersionMatch - Just lid -> checkCancelled env lid errorHandler $ do - liftIO $ completedReq env lid - runIfVersionMatch - -checkCancelled :: MonadIO m => DispatcherEnv -> J.LspId -> ErrorHandler -> m () -> m () -checkCancelled env lid errorHandler callback = do - cancelled <- liftIO $ atomically isCancelled - if cancelled - then liftIO $ do - -- remove from cancelled and wip list - atomically $ modifyTVar' (cancelReqsTVar env) (S.delete lid) - completedReq env lid - errorHandler lid J.RequestCancelled "" - else callback - where isCancelled = S.member lid <$> readTVar (cancelReqsTVar env) - -completedReq :: DispatcherEnv -> J.LspId -> IO () -completedReq env lid = atomically $ modifyTVar' (wipReqsTVar env) (S.delete lid) diff --git a/src/Haskell/Ide/Engine/Scheduler.hs b/src/Haskell/Ide/Engine/Scheduler.hs index 471403d0a..a26583df2 100644 --- a/src/Haskell/Ide/Engine/Scheduler.hs +++ b/src/Haskell/Ide/Engine/Scheduler.hs @@ -2,9 +2,12 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} module Haskell.Ide.Engine.Scheduler ( Scheduler , DocUpdate + , ErrorHandler + , CallbackHandler , newScheduler , runScheduler , sendRequest @@ -17,10 +20,12 @@ import qualified Control.Concurrent.MVar as MVar import qualified Control.Concurrent.STM as STM import Control.Monad.IO.Class ( liftIO ) import Control.Monad.Reader.Class ( ask ) +import Control.Monad.Reader ( runReaderT ) import Control.Monad.Trans.Class ( lift ) -import Control.Monad ( when ) +import Control.Monad import qualified Data.Set as Set import qualified Data.Map as Map +import qualified Data.Text as T import qualified GhcMod.Types as GM import qualified Language.Haskell.LSP.Types as J import qualified Language.Haskell.LSP.Types.Capabilities @@ -31,8 +36,9 @@ import qualified Haskell.Ide.Engine.Compat as Compat import qualified Haskell.Ide.Engine.Channel as Channel import Haskell.Ide.Engine.PluginsIdeMonads import Haskell.Ide.Engine.Types -import Haskell.Ide.Engine.Dispatcher import qualified Haskell.Ide.Engine.Monad as M +import Haskell.Ide.Engine.MonadFunctions +import Haskell.Ide.Engine.MonadTypes -- | A Scheduler is a coordinator between the two main processes the ide engine uses @@ -105,6 +111,12 @@ newScheduler plugins ghcModOptions = do , ghcChan = ghcChan } +-- | A handler for any errors that the dispatcher may encounter. +type ErrorHandler = J.LspId -> J.ErrorCode -> T.Text -> IO () + +-- | A handler to run the requests' callback in your monad of choosing. +type CallbackHandler m = forall a. RequestCallback m a -> a -> IO () + -- | Runs the given scheduler. This is meant to run in a separate thread and -- the thread should be kept alive as long as you need requests to be dispatched. @@ -195,3 +207,144 @@ cancelRequest Scheduler { requestsToCancel, requestsInProgress } lid = wip <- STM.readTVar requestsInProgress when (Set.member lid wip) $ STM.modifyTVar' requestsToCancel (Set.insert lid) + +------------------------------------------------------------------------------- +-- Dispatcher +------------------------------------------------------------------------------- + +data DispatcherEnv = DispatcherEnv + { cancelReqsTVar :: !(STM.TVar (Set.Set J.LspId)) + , wipReqsTVar :: !(STM.TVar (Set.Set J.LspId)) + , docVersionTVar :: !(STM.TVar (Map.Map Uri Int)) + } + +-- | Processes requests published in the channel and runs the give callback +-- or error handler as appropriate. Requests will not be processed if they +-- were cancelled before. If already in progress and then cancelled, the callback +-- will not be invoked in that case. +-- Meant to be run in a separate thread and be kept alive. +ideDispatcher + :: forall void m + . STM.TVar IdeState + -- ^ Holds the cached data relative to the current IDE state. + -> C.ClientCapabilities + -- ^ List of features the IDE client supports or has enabled. + -> DispatcherEnv + -- ^ A structure focusing on the mutable variables the dispatcher + -- is allowed to modify. + -> ErrorHandler + -- ^ Callback to run in case of errors. + -> CallbackHandler m + -- ^ Callback to run for handling the request. + -> Channel.OutChan (IdeRequest m) + -- ^ Reading end of the channel where the requests are sent to this process. + -> IO void +ideDispatcher stateVar caps env errorHandler callbackHandler pin = + -- TODO: AZ run a single ReaderT, with a composite R. + flip runReaderT stateVar $ flip runReaderT caps $ forever $ do + debugm "ideDispatcher: top of loop" + (IdeRequest tn lid callback action) <- liftIO $ Channel.readChan pin + debugm + $ "ideDispatcher: got request " + ++ show tn + ++ " with id: " + ++ show lid + + iterT queueDeferred $ unlessCancelled env lid errorHandler $ do + result <- action + unlessCancelled env lid errorHandler $ liftIO $ do + completedReq env lid + case result of + IdeResultOk x -> callbackHandler callback x + IdeResultFail (IdeError _ msg _) -> + errorHandler lid J.InternalError msg + where + queueDeferred (Defer fp cacheCb) = lift $ modifyMTState $ \s -> + let oldQueue = requestQueue s + -- add to existing queue if possible + update Nothing = [cacheCb] + update (Just x) = cacheCb : x + newQueue = Map.alter (Just . update) fp oldQueue + in s { requestQueue = newQueue } + +-- | Processes requests published in the channel and runs the give callback +-- or error handler as appropriate. Requests will not be processed if they +-- were cancelled before. If already in progress and then cancelled, the callback +-- will not be invoked in that case. +-- Meant to be run in a separate thread and be kept alive. +ghcDispatcher + :: forall void m + . DispatcherEnv + -> ErrorHandler + -> CallbackHandler m + -> Channel.OutChan (GhcRequest m) + -> IdeGhcM void +ghcDispatcher env@DispatcherEnv { docVersionTVar } errorHandler callbackHandler pin + = forever $ do + debugm "ghcDispatcher: top of loop" + (GhcRequest tn context mver mid callback action) <- liftIO + $ Channel.readChan pin + debugm $ "ghcDispatcher:got request " ++ show tn ++ " with id: " ++ show mid + + let + runner = case context of + Nothing -> runActionWithContext Nothing + Just uri -> case uriToFilePath uri of + Just fp -> runActionWithContext (Just fp) + Nothing -> \act -> do + debugm + "ghcDispatcher:Got malformed uri, running action with default context" + runActionWithContext Nothing act + + let + runWithCallback = do + result <- runner action + liftIO $ case result of + IdeResultOk x -> callbackHandler callback x + IdeResultFail err@(IdeError _ msg _) -> case mid of + Just lid -> errorHandler lid J.InternalError msg + Nothing -> + debugm $ "ghcDispatcher:Got error for a request: " ++ show err + + let + runIfVersionMatch = case mver of + Nothing -> runWithCallback + Just (uri, reqver) -> do + curver <- + liftIO + $ STM.atomically + $ Map.lookup uri + <$> STM.readTVar docVersionTVar + if Just reqver /= curver + then debugm + "ghcDispatcher:not processing request as it is for old version" + else do + debugm "ghcDispatcher:Processing request as version matches" + runWithCallback + + case mid of + Nothing -> runIfVersionMatch + Just lid -> unlessCancelled env lid errorHandler $ do + liftIO $ completedReq env lid + runIfVersionMatch + +-- | Runs the passed monad only if the request identified by the passed LspId +-- has not already been cancelled. +unlessCancelled + :: GM.MonadIO m => DispatcherEnv -> J.LspId -> ErrorHandler -> m () -> m () +unlessCancelled env lid errorHandler callback = do + cancelled <- liftIO $ STM.atomically isCancelled + if cancelled + then liftIO $ do + -- remove from cancelled and wip list + STM.atomically $ STM.modifyTVar' (cancelReqsTVar env) (Set.delete lid) + completedReq env lid + errorHandler lid J.RequestCancelled "" + else callback + where isCancelled = Set.member lid <$> STM.readTVar (cancelReqsTVar env) + +-- | Marks a request as completed by deleting the LspId from the +-- requestsInProgress Set. +completedReq :: DispatcherEnv -> J.LspId -> IO () +completedReq env lid = + STM.atomically $ STM.modifyTVar' (wipReqsTVar env) (Set.delete lid) diff --git a/src/Haskell/Ide/Engine/Transport/LspStdio.hs b/src/Haskell/Ide/Engine/Transport/LspStdio.hs index 89f4c297d..3ebd82f66 100644 --- a/src/Haskell/Ide/Engine/Transport/LspStdio.hs +++ b/src/Haskell/Ide/Engine/Transport/LspStdio.hs @@ -45,7 +45,6 @@ import qualified GhcMod.Monad.Types as GM import Haskell.Ide.Engine.PluginDescriptor import Haskell.Ide.Engine.MonadFunctions import Haskell.Ide.Engine.MonadTypes -import Haskell.Ide.Engine.Dispatcher import Haskell.Ide.Engine.PluginUtils import qualified Haskell.Ide.Engine.Scheduler as Scheduler import Haskell.Ide.Engine.Types @@ -130,10 +129,10 @@ run scheduler _origDir plugins captureFp = flip E.catches handlers $ do let reactorFunc = react $ reactor rin diagIn caps = Core.clientCapabilities lf - let errorHandler :: ErrorHandler + let errorHandler :: Scheduler.ErrorHandler errorHandler lid code e = Core.sendErrorResponseS (Core.sendFunc lf) (J.responseId lid) code e - callbackHandler :: CallbackHandler R + callbackHandler :: Scheduler.CallbackHandler R callbackHandler f x = react $ f x -- This is the callback the debouncer executes at the end of the timeout, From 49e78759caa26eb32df5bac5f1382c3027eca106 Mon Sep 17 00:00:00 2001 From: Jose Lorenzo Rodriguez Date: Sun, 28 Oct 2018 17:52:43 +0100 Subject: [PATCH 07/11] Moving some more functions to the Scheduler module --- src/Haskell/Ide/Engine/LSP/Reactor.hs | 16 ++++++------ src/Haskell/Ide/Engine/Scheduler.hs | 37 +++++++++++++++++++++++++-- 2 files changed, 43 insertions(+), 10 deletions(-) diff --git a/src/Haskell/Ide/Engine/LSP/Reactor.hs b/src/Haskell/Ide/Engine/LSP/Reactor.hs index e08e184d8..169cb7668 100644 --- a/src/Haskell/Ide/Engine/LSP/Reactor.hs +++ b/src/Haskell/Ide/Engine/LSP/Reactor.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} module Haskell.Ide.Engine.LSP.Reactor ( R , runReactor @@ -41,6 +42,9 @@ type R = ReaderT REnv IO instance HasPidCache R where getPidCache = asks reactorPidCache +instance Scheduler.HasScheduler REnv R where + getScheduler = scheduler + -- --------------------------------------------------------------------- runReactor @@ -82,17 +86,13 @@ reactorSend' f = do -- | Sends a single request to the scheduler so it can be be processed -- asynchronously. makeRequest :: (MonadIO m, MonadReader REnv m) => PluginRequest R -> m () -makeRequest req = do - sc <- asks scheduler - liftIO $ Scheduler.sendRequest sc Nothing req +makeRequest = Scheduler.makeRequest -- | Updates the version of a document and then sends the request to be processed -- asynchronously. updateDocumentRequest :: (MonadIO m, MonadReader REnv m) => Uri -> Int -> PluginRequest R -> m () -updateDocumentRequest uri ver req = do - sc <- asks scheduler - liftIO $ Scheduler.sendRequest sc (Just (uri, ver)) req +updateDocumentRequest = Scheduler.updateDocumentRequest -- | Marks a s requests as cencelled by its LspId cancelRequest :: (MonadIO m, MonadReader REnv m) => J.LspId -> m () diff --git a/src/Haskell/Ide/Engine/Scheduler.hs b/src/Haskell/Ide/Engine/Scheduler.hs index a26583df2..832457f34 100644 --- a/src/Haskell/Ide/Engine/Scheduler.hs +++ b/src/Haskell/Ide/Engine/Scheduler.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} @@ -8,18 +9,25 @@ module Haskell.Ide.Engine.Scheduler , DocUpdate , ErrorHandler , CallbackHandler + , HasScheduler(..) , newScheduler , runScheduler , sendRequest , cancelRequest + , makeRequest + , updateDocumentRequest ) where import Control.Concurrent.Async ( race_ ) import qualified Control.Concurrent.MVar as MVar import qualified Control.Concurrent.STM as STM -import Control.Monad.IO.Class ( liftIO ) -import Control.Monad.Reader.Class ( ask ) +import Control.Monad.IO.Class ( liftIO + , MonadIO + ) +import Control.Monad.Reader.Class ( ask + , MonadReader + ) import Control.Monad.Reader ( runReaderT ) import Control.Monad.Trans.Class ( lift ) import Control.Monad @@ -85,6 +93,9 @@ data Scheduler m = Scheduler type DocUpdate = (Uri, Int) +class HasScheduler a m where + getScheduler :: a -> Scheduler m + -- | Create a new scheduler parameterized with the monad of your choosing. -- This is the monad where the handler for requests and handler for errors will run. -- @@ -208,6 +219,28 @@ cancelRequest Scheduler { requestsToCancel, requestsInProgress } lid = when (Set.member lid wip) $ STM.modifyTVar' requestsToCancel (Set.insert lid) +-- | Sends a single request to the scheduler so it can be be processed +-- asynchronously. +makeRequest + :: (MonadReader env m, MonadIO m, HasScheduler env m2) + => PluginRequest m2 + -> m () +makeRequest req = do + env <- ask + liftIO $ sendRequest (getScheduler env) Nothing req + +-- | Updates the version of a document and then sends the request to be processed +-- asynchronously. +updateDocumentRequest + :: (MonadReader env m, MonadIO m, HasScheduler env m2) + => Uri + -> Int + -> PluginRequest m2 + -> m () +updateDocumentRequest uri ver req = do + env <- ask + liftIO $ sendRequest (getScheduler env) (Just (uri, ver)) req + ------------------------------------------------------------------------------- -- Dispatcher ------------------------------------------------------------------------------- From 339224f496b9bbe96b3f88aa2101c67016224c48 Mon Sep 17 00:00:00 2001 From: Jose Lorenzo Rodriguez Date: Mon, 29 Oct 2018 11:53:24 +0100 Subject: [PATCH 08/11] commenting out test code to debug circleci --- test/dispatcher/Main.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/test/dispatcher/Main.hs b/test/dispatcher/Main.hs index d07133bef..e07862ef3 100644 --- a/test/dispatcher/Main.hs +++ b/test/dispatcher/Main.hs @@ -41,9 +41,9 @@ import Haskell.Ide.Engine.Plugin.HieExtras main :: IO () main = do setupStackFiles - withFileLogging "main-dispatcher.log" $ do - hspec newPluginSpec - hspec funcSpec + -- withFileLogging "main-dispatcher.log" $ do + -- hspec newPluginSpec + -- hspec funcSpec -- main :: IO () -- main = do From 1d44a0d6fab9678a50bc82e5fd7e04bc06219347 Mon Sep 17 00:00:00 2001 From: Jose Lorenzo Rodriguez Date: Mon, 29 Oct 2018 13:45:02 +0100 Subject: [PATCH 09/11] Revert "commenting out test code to debug circleci" This reverts commit 339224f496b9bbe96b3f88aa2101c67016224c48. --- test/dispatcher/Main.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/test/dispatcher/Main.hs b/test/dispatcher/Main.hs index e07862ef3..d07133bef 100644 --- a/test/dispatcher/Main.hs +++ b/test/dispatcher/Main.hs @@ -41,9 +41,9 @@ import Haskell.Ide.Engine.Plugin.HieExtras main :: IO () main = do setupStackFiles - -- withFileLogging "main-dispatcher.log" $ do - -- hspec newPluginSpec - -- hspec funcSpec + withFileLogging "main-dispatcher.log" $ do + hspec newPluginSpec + hspec funcSpec -- main :: IO () -- main = do From 4901968663b4ea6255661d7581d10e567fc7ca53 Mon Sep 17 00:00:00 2001 From: Jose Lorenzo Rodriguez Date: Mon, 29 Oct 2018 13:46:03 +0100 Subject: [PATCH 10/11] Only one thread for tests --- .circleci/config.yml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/.circleci/config.yml b/.circleci/config.yml index ba7c40f23..c9ac7d57a 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -69,7 +69,8 @@ defaults: &defaults - run: name: Test - command: stack -j 2 --stack-yaml=${STACK_FILE} test --dump-logs + # Tests MUST run with -j1, since multiple ghc-mod sessions are not allowed + command: stack -j 1 --stack-yaml=${STACK_FILE} test --dump-logs no_output_timeout: 120m - store_artifacts: From 9e22aa624a59aefdecb7c82f42ca2a22339888ad Mon Sep 17 00:00:00 2001 From: Jose Lorenzo Rodriguez Date: Mon, 29 Oct 2018 15:08:17 +0100 Subject: [PATCH 11/11] Splitting tests into another package to avoid race condition --- haskell-ide-engine.cabal | 33 ++++++++++++++++++ test/dispatcher/Main.hs | 35 ------------------- test/plugin-dispatcher/Main.hs | 63 ++++++++++++++++++++++++++++++++++ 3 files changed, 96 insertions(+), 35 deletions(-) create mode 100644 test/plugin-dispatcher/Main.hs diff --git a/haskell-ide-engine.cabal b/haskell-ide-engine.cabal index 6a876e4e0..3c8e0245b 100644 --- a/haskell-ide-engine.cabal +++ b/haskell-ide-engine.cabal @@ -222,6 +222,39 @@ test-suite dispatcher-test default-language: Haskell2010 build-tool-depends: hspec-discover:hspec-discover +test-suite plugin-dispatcher-test + type: exitcode-stdio-1.0 + hs-source-dirs: test/plugin-dispatcher + test/utils + main-is: Main.hs + other-modules: TestUtils + build-depends: base + , aeson + , containers + , data-default + , directory + , filepath + , ghc + , haskell-lsp + , haskell-ide-engine + -- , hie-test-utils + , hie-plugin-api + , hspec + , stm + , text + , unordered-containers + + -- remove these once hie-test-utils is reinstated + , hie-plugin-api + , ghc-mod-core + , hslogger + , unordered-containers + , yaml + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Wredundant-constraints + if flag(pedantic) + ghc-options: -Werror + default-language: Haskell2010 + -- library hie-test-utils -- hs-source-dirs: test/utils -- exposed-modules: TestUtils diff --git a/test/dispatcher/Main.hs b/test/dispatcher/Main.hs index d07133bef..5c3c0b862 100644 --- a/test/dispatcher/Main.hs +++ b/test/dispatcher/Main.hs @@ -42,7 +42,6 @@ main :: IO () main = do setupStackFiles withFileLogging "main-dispatcher.log" $ do - hspec newPluginSpec hspec funcSpec -- main :: IO () @@ -124,40 +123,6 @@ instance ToJSON Cached where -- --------------------------------------------------------------------- -newPluginSpec :: Spec -newPluginSpec = do - describe "New plugin dispatcher operation" $ - it "dispatches response correctly" $ do - outChan <- atomically newTChan - scheduler <- newScheduler (pluginDescToIdePlugins []) testOptions - let defCallback = atomically . writeTChan outChan - delayedCallback = \r -> threadDelay 10000 >> defCallback r - - let req0 = GReq 0 Nothing Nothing (Just $ IdInt 0) (\_ -> return () :: IO ()) $ return $ IdeResultOk $ T.pack "text0" - req1 = GReq 1 Nothing Nothing (Just $ IdInt 1) defCallback $ return $ IdeResultOk $ T.pack "text1" - req2 = GReq 2 Nothing Nothing (Just $ IdInt 2) delayedCallback $ return $ IdeResultOk $ T.pack "text2" - req3 = GReq 3 Nothing (Just (filePathToUri "test", 2)) Nothing defCallback $ return $ IdeResultOk $ T.pack "text3" - req4 = GReq 4 Nothing Nothing (Just $ IdInt 3) defCallback $ return $ IdeResultOk $ T.pack "text4" - - let makeReq = sendRequest scheduler Nothing - - pid <- forkIO $ runScheduler scheduler - (\_ _ _ -> return ()) - (\f x -> f x) - def - - sendRequest scheduler (Just (filePathToUri "test", 3)) req0 - makeReq req1 - makeReq req2 - cancelRequest scheduler (IdInt 2) - makeReq req3 - makeReq req4 - resp1 <- atomically $ readTChan outChan - resp2 <- atomically $ readTChan outChan - killThread pid - resp1 `shouldBe` "text1" - resp2 `shouldBe` "text4" - funcSpec :: Spec funcSpec = describe "functional dispatch" $ do runIO $ setCurrentDirectory "test/testdata" diff --git a/test/plugin-dispatcher/Main.hs b/test/plugin-dispatcher/Main.hs new file mode 100644 index 000000000..e226f24e1 --- /dev/null +++ b/test/plugin-dispatcher/Main.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DuplicateRecordFields #-} +module Main where + +import Control.Concurrent +import Control.Concurrent.STM.TChan +import Control.Monad.STM +import qualified Data.Text as T +import Data.Default +import Haskell.Ide.Engine.MonadTypes +import Haskell.Ide.Engine.PluginDescriptor +import Haskell.Ide.Engine.Scheduler +import Haskell.Ide.Engine.Types +import Language.Haskell.LSP.Types +import TestUtils + +import Test.Hspec + +-- --------------------------------------------------------------------- + +main :: IO () +main = do + setupStackFiles + withFileLogging "plugin-dispatcher.log" $ do + hspec newPluginSpec + +-- --------------------------------------------------------------------- + +newPluginSpec :: Spec +newPluginSpec = do + describe "New plugin dispatcher operation" $ + it "dispatches response correctly" $ do + outChan <- atomically newTChan + scheduler <- newScheduler (pluginDescToIdePlugins []) testOptions + let defCallback = atomically . writeTChan outChan + delayedCallback = \r -> threadDelay 10000 >> defCallback r + + let req0 = GReq 0 Nothing Nothing (Just $ IdInt 0) (\_ -> return () :: IO ()) $ return $ IdeResultOk $ T.pack "text0" + req1 = GReq 1 Nothing Nothing (Just $ IdInt 1) defCallback $ return $ IdeResultOk $ T.pack "text1" + req2 = GReq 2 Nothing Nothing (Just $ IdInt 2) delayedCallback $ return $ IdeResultOk $ T.pack "text2" + req3 = GReq 3 Nothing (Just (filePathToUri "test", 2)) Nothing defCallback $ return $ IdeResultOk $ T.pack "text3" + req4 = GReq 4 Nothing Nothing (Just $ IdInt 3) defCallback $ return $ IdeResultOk $ T.pack "text4" + + let makeReq = sendRequest scheduler Nothing + + pid <- forkIO $ runScheduler scheduler + (\_ _ _ -> return ()) + (\f x -> f x) + def + + sendRequest scheduler (Just (filePathToUri "test", 3)) req0 + makeReq req1 + makeReq req2 + cancelRequest scheduler (IdInt 2) + makeReq req3 + makeReq req4 + resp1 <- atomically $ readTChan outChan + resp2 <- atomically $ readTChan outChan + killThread pid + resp1 `shouldBe` "text1" + resp2 `shouldBe` "text4" + +