Merge pull request #864 from haskell/refactor-dispatcher

Refactor DispatcherEnv our of the Reactor

Author: lorenzo

.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:

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
@@ -145,8 +143,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)

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.

haskell-ide-engine.cabal

@@ -20,7 +20,8 @@ flag pedantic
 library
   hs-source-dirs:      src
   exposed-modules:     Haskell.Ide.Engine.Plugin.Base
-                       Haskell.Ide.Engine.Dispatcher
+                       Haskell.Ide.Engine.Channel
+                       Haskell.Ide.Engine.Scheduler
                        Haskell.Ide.Engine.LSP.CodeActions
                        Haskell.Ide.Engine.LSP.Config
                        Haskell.Ide.Engine.LSP.Reactor
@@ -221,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

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