concurrent-tests setting #492

ChangeLog.md

@@ -14,6 +14,7 @@
 * Rename `stack docker exec` to `stack exec --plain`
 * Add the `--skip-msys` flag [#377](https://github.com/commercialhaskell/stack/issues/377)
 * `--keep-going`, turned on by default for tests and benchmarks [#478](https://github.com/commercialhaskell/stack/issues/478)
+* `concurrent-tests: BOOL` [#492](https://github.com/commercialhaskell/stack/issues/492)
 
 ## 0.1.1.0
 

src/Control/Concurrent/Execute.hs

@@ -45,6 +45,7 @@ data ExecuteState = ExecuteState
     , esExceptions :: TVar [SomeException]
     , esInAction   :: TVar (Set ActionId)
     , esCompleted  :: TVar Int
+    , esFinalLock  :: Maybe (TMVar ())
     , esKeepGoing  :: Bool
     }
 
@@ -59,15 +60,19 @@ instance Show ExecuteException where
 
 runActions :: Int -- ^ threads
            -> Bool -- ^ keep going after one task has failed
+           -> Bool -- ^ run final actions concurrently?
            -> [Action]
            -> (TVar Int -> IO ()) -- ^ progress updated
            -> IO [SomeException]
-runActions threads keepGoing actions0 withProgress = do
+runActions threads keepGoing concurrentFinal actions0 withProgress = do
     es <- ExecuteState
         <$> newTVarIO actions0
         <*> newTVarIO []
         <*> newTVarIO Set.empty
         <*> newTVarIO 0
+        <*> (if concurrentFinal
+                then pure Nothing
+                else Just <$> atomically (newTMVar ()))
         <*> pure keepGoing
     _ <- async $ withProgress $ esCompleted es
     if threads <= 1
@@ -100,6 +105,13 @@ runActions' ExecuteState {..} =
                         return $ return ()
                     else retry
             (xs, action:ys) -> do
+                unlock <-
+                    case (actionId action, esFinalLock) of
+                        (ActionId _ ATFinal, Just lock) -> do
+                            takeTMVar lock
+                            return $ putTMVar lock ()
+                        _ -> return $ return ()
+
                 let as' = xs ++ ys
                 inAction <- readTVar esInAction
                 let remaining = Set.union
@@ -112,6 +124,7 @@ runActions' ExecuteState {..} =
                         { acRemaining = remaining
                         }
                     atomically $ do
+                        unlock
                         modifyTVar esInAction (Set.delete $ actionId action)
                         modifyTVar esCompleted (+1)
                         case eres of

src/Stack/Build/Execute.hs

@@ -333,15 +333,20 @@ executePlan' plan ee@ExecuteEnv {..} = do
             (planTasks plan)
             (planFinals plan)
     threads <- asks $ configJobs . getConfig
+    concurrentTests <- asks $ configConcurrentTests . getConfig
     let keepGoing =
             case boptsKeepGoing eeBuildOpts of
                 Just kg -> kg
                 Nothing ->
                     case boptsFinalAction eeBuildOpts of
                         DoNothing -> False
                         _ -> True
+        concurrentFinal =
+            case boptsFinalAction eeBuildOpts of
+                DoTests _ -> concurrentTests
+                _ -> True
     terminal <- asks getTerminal
-    errs <- liftIO $ runActions threads keepGoing actions $ \doneVar -> do
+    errs <- liftIO $ runActions threads keepGoing concurrentFinal actions $ \doneVar -> do
         let total = length actions
             loop prev
                 | prev == total =

src/Stack/Config.hs

@@ -154,6 +154,7 @@ configFromConfigMonoid configStackRoot mproject configMonoid@ConfigMonoid{..} =
         case configMonoidJobs of
             Nothing -> liftIO getNumCapabilities
             Just i -> return i
+     let configConcurrentTests = fromMaybe True configMonoidConcurrentTests
 
      return Config {..}
 

src/Stack/Types/Config.hs

@@ -101,6 +101,8 @@ data Config =
          -- ^ --extra-lib-dirs arguments
          ,configConfigMonoid        :: !ConfigMonoid
          -- ^ @ConfigMonoid@ used to generate this
+         ,configConcurrentTests     :: !Bool
+         -- ^ Run test suites concurrently
          }
 
 -- | Information on a single package index
@@ -432,6 +434,8 @@ data ConfigMonoid =
     -- ^ See: 'configExtraIncludeDirs'
     ,configMonoidExtraLibDirs        :: !(Set Text)
     -- ^ See: 'configExtraLibDirs'
+    ,configMonoidConcurrentTests     :: !(Maybe Bool)
+    -- ^ See: 'configConcurrentTests'
     }
   deriving Show
 
@@ -452,6 +456,7 @@ instance Monoid ConfigMonoid where
     , configMonoidJobs = Nothing
     , configMonoidExtraIncludeDirs = Set.empty
     , configMonoidExtraLibDirs = Set.empty
+    , configMonoidConcurrentTests = Nothing
     }
   mappend l r = ConfigMonoid
     { configMonoidDockerOpts = configMonoidDockerOpts l <> configMonoidDockerOpts r
@@ -470,6 +475,7 @@ instance Monoid ConfigMonoid where
     , configMonoidJobs = configMonoidJobs l <|> configMonoidJobs r
     , configMonoidExtraIncludeDirs = Set.union (configMonoidExtraIncludeDirs l) (configMonoidExtraIncludeDirs r)
     , configMonoidExtraLibDirs = Set.union (configMonoidExtraLibDirs l) (configMonoidExtraLibDirs r)
+    , configMonoidConcurrentTests = configMonoidConcurrentTests l <|> configMonoidConcurrentTests r
     }
 
 instance FromJSON ConfigMonoid where
@@ -493,6 +499,7 @@ instance FromJSON ConfigMonoid where
          configMonoidJobs <- obj .:? "jobs"
          configMonoidExtraIncludeDirs <- obj .:? "extra-include-dirs" .!= Set.empty
          configMonoidExtraLibDirs <- obj .:? "extra-lib-dirs" .!= Set.empty
+         configMonoidConcurrentTests <- obj .:? "concurrent-tests"
          return ConfigMonoid {..}
 
 -- | Newtype for non-orphan FromJSON instance.