cleanup

Author: soulomoon

hls-graph/src/Development/IDE/Graph/Internal/Action.hs

@@ -21,8 +21,9 @@ import           Control.Concurrent.STM.Stats            (atomicallyNamed)
 import           Control.DeepSeq                         (force)
 import           Control.Exception
 import           Control.Monad.IO.Class
+import           Control.Monad.RWS                       (MonadReader (ask),
+                                                          asks)
 import           Control.Monad.Trans.Class
-import           Control.Monad.Trans.Reader
 import           Data.Foldable                           (toList)
 import           Data.Functor.Identity
 import           Data.IORef
@@ -41,13 +42,13 @@ type ShakeValue a = (Show a, Typeable a, Eq a, Hashable a, NFData a)
 -- | Always rerun this rule when dirty, regardless of the dependencies.
 alwaysRerun :: Action ()
 alwaysRerun = do
-    ref <- Action $ asks actionDeps
+    ref <- asks actionDeps
     liftIO $ modifyIORef' ref (AlwaysRerunDeps mempty <>)
 
 parallel :: [Action a] -> Action [Either SomeException a]
 parallel [] = return []
 parallel xs = do
-    a <- Action ask
+    a <- ask
     deps <- liftIO $ readIORef $ actionDeps a
     case deps of
         UnknownDeps ->
@@ -61,15 +62,15 @@ parallel xs = do
 -- non-blocking version of runActionInDb
 runActionInDbCb :: (a -> String) -> (a -> Action result) -> STM a -> (Either SomeException result -> IO ()) -> Action a
 runActionInDbCb getTitle work getAct handler = do
-    a <- Action ask
+    a <- ask
     liftIO $ atomicallyNamed "action queue - pop" $ do
         act <- getAct
         runInDataBase (getTitle act) (actionDatabase a) [(ignoreState a $ work act, handler)]
         return act
 
 runActionInDb :: String -> [Action a] -> Action [Either SomeException a]
 runActionInDb title acts = do
-    a <- Action ask
+    a <- ask
     xs <- mapM (\x -> do
         barrier <- newEmptyTMVarIO
         return (x, barrier)) acts
@@ -81,7 +82,7 @@ runActionInDb title acts = do
 ignoreState :: SAction -> Action b -> IO b
 ignoreState a x = do
     ref <- newIORef mempty
-    runReaderT (fromAction x) a{actionDeps=ref}
+    runActionMonad x a{actionDeps=ref}
 
 isAsyncException :: SomeException -> Bool
 isAsyncException e
@@ -95,8 +96,8 @@ isAsyncException e
 
 actionCatch :: Exception e => Action a -> (e -> Action a) -> Action a
 actionCatch a b = do
-    v <- Action ask
-    Action $ lift $ catchJust f (runReaderT (fromAction a) v) (\x -> runReaderT (fromAction (b x)) v)
+    v <- ask
+    liftIO $ catchJust f (runActionMonad a v) (\x -> runActionMonad (b x) v)
     where
         -- Catch only catches exceptions that were caused by this code, not those that
         -- are a result of program termination
@@ -105,41 +106,41 @@ actionCatch a b = do
 
 actionBracket :: IO a -> (a -> IO b) -> (a -> Action c) -> Action c
 actionBracket a b c = do
-    v <- Action ask
-    Action $ lift $ bracket a b (\x -> runReaderT (fromAction (c x)) v)
+    v <- ask
+    liftIO $ bracket a b (\x -> runActionMonad (c x) v)
 
 actionFinally :: Action a -> IO b -> Action a
 actionFinally a b = do
     v <- Action ask
-    Action $ lift $ finally (runReaderT (fromAction a) v) b
+    Action $ lift $ finally (runActionMonad a v) b
 
 apply1 :: (RuleResult key ~ value, ShakeValue key, Typeable value) => key -> Action value
 apply1 k = runIdentity <$> apply (Identity k)
 
 apply :: (Traversable f, RuleResult key ~ value, ShakeValue key, Typeable value) => f key -> Action (f value)
 apply ks = do
-    db <- Action $ asks actionDatabase
-    stack <- Action $ asks actionStack
+    db <- asks actionDatabase
+    stack <- asks actionStack
     pk <- getActionKey
     (is, vs) <- liftIO $ build pk db stack ks
-    ref <- Action $ asks actionDeps
+    ref <- asks actionDeps
     let !ks = force $ fromListKeySet $ toList is
     liftIO $ modifyIORef' ref (ResultDeps [ks] <>)
     pure vs
 
 -- | Evaluate a list of keys without recording any dependencies.
 applyWithoutDependency :: (Traversable f, RuleResult key ~ value, ShakeValue key, Typeable value) => f key -> Action (f value)
 applyWithoutDependency ks = do
-    db <- Action $ asks actionDatabase
-    stack <- Action $ asks actionStack
+    db <- asks actionDatabase
+    stack <- asks actionStack
     pk <- getActionKey
     (_, vs) <- liftIO $ build pk db stack ks
     pure vs
 
 runActions :: Key -> Database -> [Action a] -> IO [Either SomeException a]
 runActions pk db xs = do
     deps <- newIORef mempty
-    runReaderT (fromAction $ parallel xs) $ SAction pk db deps emptyStack
+    runActionMonad (parallel xs) $ SAction pk db deps emptyStack
 
 -- | Returns the set of dirty keys annotated with their age (in # of builds)
 getDirtySet  :: Action [(Key, Int)]

hls-graph/src/Development/IDE/Graph/Internal/Types.hs

@@ -11,7 +11,8 @@ import           Control.Monad                      (forM, forM_, forever,
                                                      unless, when)
 import           Control.Monad.Catch
 import           Control.Monad.IO.Class
-import           Control.Monad.Trans.Reader
+import           Control.Monad.RWS                  (MonadReader (local), asks)
+import           Control.Monad.Trans.Reader         (ReaderT (..))
 import           Data.Aeson                         (FromJSON, ToJSON)
 import           Data.Bifunctor                     (second)
 import qualified Data.ByteString                    as BS
@@ -88,7 +89,10 @@ data SRules = SRules {
 -- 'Development.IDE.Graph.Internal.Action.actionCatch'. In particular, it is
 -- permissible to use the 'MonadFail' instance, which will lead to an 'IOException'.
 newtype Action a = Action {fromAction :: ReaderT SAction IO a}
-    deriving newtype (Monad, Applicative, Functor, MonadIO, MonadFail, MonadThrow, MonadCatch, MonadMask, MonadUnliftIO)
+    deriving newtype (Monad, Applicative, Functor, MonadIO, MonadFail, MonadThrow, MonadCatch, MonadMask, MonadUnliftIO, MonadReader SAction)
+
+runActionMonad :: Action a ->  SAction -> IO a
+runActionMonad (Action r) s = runReaderT r s
 
 data SAction = SAction {
     actionKey      :: !Key,
@@ -98,14 +102,13 @@ data SAction = SAction {
     }
 
 getDatabase :: Action Database
-getDatabase = Action $ asks actionDatabase
+getDatabase = asks actionDatabase
 
 getActionKey :: Action Key
-getActionKey = Action $ asks actionKey
+getActionKey = asks actionKey
 
 setActionKey :: Key -> Action a -> Action a
-setActionKey k (Action act) = Action $ do
-    local (\s' -> s'{actionKey = k}) act
+setActionKey k act = local (\s' -> s'{actionKey = k}) act
 
 -- | waitForDatabaseRunningKeysAction waits for all keys in the database to finish running.
 -- waitForDatabaseRunningKeysAction :: Action ()

hls-graph/src/Development/IDE/WorkerThread.hs

@@ -25,7 +25,8 @@ module Development.IDE.WorkerThread
     tryReadTaskQueue,
     withWorkerQueueSimpleRight,
     submitWorkAtHead,
-    awaitRunInThread
+    awaitRunInThread,
+    withAsyncs
   ) where
 
 import           Control.Concurrent.Async           (withAsync)
@@ -81,8 +82,12 @@ withWorkerQueueSimple log title = withWorkerQueue log title id
 
 withWorkerQueueSimpleRight :: Logger -> T.Text -> ContT () IO (TaskQueue (Either Dynamic (IO ())))
 withWorkerQueueSimpleRight log title = withWorkerQueue log title $ eitherWorker (const $ return ()) id
+
+
 withWorkerQueue :: Logger -> T.Text -> (t -> IO ()) -> ContT () IO (TaskQueue t)
-withWorkerQueue log title workerAction = ContT $ \mainAction -> do
+withWorkerQueue = withWorkersQueue 1
+withWorkersQueue :: Int -> Logger -> T.Text -> (t -> IO ()) -> ContT () IO (TaskQueue t)
+withWorkersQueue n log title workerAction = ContT $ \mainAction -> do
   tid <- myThreadId
   log (LogMainThreadId title tid)
   q <- newTaskQueueIO
@@ -94,7 +99,7 @@ withWorkerQueue log title workerAction = ContT $ \mainAction -> do
   -- If 'cancel' does interrupt the thread (e.g., while blocked in STM or in a cooperative job),
   -- the thread exits immediately and never checks the TMVar; in such cases, the stop flag is redundant.
   b <- newEmptyTMVarIO
-  withAsync (writerThread q b) $ \_ -> do
+  withAsyncs (replicate n (writerThread q b)) $ do
     mainAction q
     -- if we want to debug the exact location the worker swallows an async exception, we can
     -- temporarily comment out the `finally` clause.
@@ -121,6 +126,11 @@ withWorkerQueue log title workerAction = ContT $ \mainAction -> do
                 log $ LogSingleWorkEnded title
                 writerThread q b
 
+withAsyncs :: [IO ()] -> IO () -> IO ()
+withAsyncs ios mainAction = go ios
+    where
+        go []     = mainAction
+        go (x:xs) = withAsync x $ \_ -> go xs
 
 -- | 'awaitRunInThread' queues up an 'IO' action to be run by a worker thread,
 -- and then blocks until the result is computed. If the action throws an