--keep-going #478

commercialhaskell · Jul 3, 2015 · e94aa71 · e94aa71
1 parent 2668f9b
commit e94aa71
Show file tree

Hide file tree

Showing 5 changed files with 34 additions and 17 deletions.
diff --git a/ChangeLog.md b/ChangeLog.md
@@ -13,6 +13,7 @@
 * Add the __`--file-watch`__ flag to auto-rebuild on file changes [#113](https://github.com/commercialhaskell/stack/issues/113)
 * 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)
 
 ## 0.1.1.0
 

diff --git a/src/Control/Concurrent/Execute.hs b/src/Control/Concurrent/Execute.hs
@@ -14,7 +14,7 @@ import           Control.Applicative
 import           Control.Concurrent.Async (Concurrently (..), async)
 import           Control.Concurrent.STM
 import           Control.Exception
-import           Control.Monad            (join)
+import           Control.Monad            (join, unless)
 import           Data.Foldable            (sequenceA_)
 import           Data.Set                 (Set)
 import qualified Data.Set                 as Set
@@ -45,6 +45,7 @@ data ExecuteState = ExecuteState
     , esExceptions :: TVar [SomeException]
     , esInAction   :: TVar (Set ActionId)
     , esCompleted  :: TVar Int
+    , esKeepGoing  :: Bool
     }
 
 data ExecuteException
@@ -57,15 +58,17 @@ instance Show ExecuteException where
         "Inconsistent dependencies were discovered while executing your build plan. This should never happen, please report it as a bug to the stack team."
 
 runActions :: Int -- ^ threads
+           -> Bool -- ^ keep going after one task has failed
            -> [Action]
            -> (TVar Int -> IO ()) -- ^ progress updated
            -> IO [SomeException]
-runActions threads actions0 withProgress = do
+runActions threads keepGoing actions0 withProgress = do
     es <- ExecuteState
         <$> newTVarIO actions0
         <*> newTVarIO []
         <*> newTVarIO Set.empty
         <*> newTVarIO 0
+        <*> pure keepGoing
     _ <- async $ withProgress $ esCompleted es
     if threads <= 1
         then runActions' es
@@ -78,7 +81,7 @@ runActions' ExecuteState {..} =
   where
     breakOnErrs inner = do
         errs <- readTVar esExceptions
-        if null errs
+        if null errs || esKeepGoing
             then inner
             else return $ return ()
     withActions inner = do
@@ -92,7 +95,8 @@ runActions' ExecuteState {..} =
                 inAction <- readTVar esInAction
                 if Set.null inAction
                     then do
-                        modifyTVar esExceptions (toException InconsistentDependencies:)
+                        unless esKeepGoing $
+                            modifyTVar esExceptions (toException InconsistentDependencies:)
                         return $ return ()
                     else retry
             (xs, action:ys) -> do
@@ -107,15 +111,12 @@ runActions' ExecuteState {..} =
                     eres <- try $ restore $ actionDo action ActionContext
                         { acRemaining = remaining
                         }
-                    case eres of
-                        Left err -> atomically $ do
-                            modifyTVar esExceptions (err:)
-                            modifyTVar esInAction (Set.delete $ actionId action)
-                            modifyTVar esCompleted (+1)
-                        Right () -> do
-                            atomically $ do
-                                modifyTVar esInAction (Set.delete $ actionId action)
-                                modifyTVar esCompleted (+1)
+                    atomically $ do
+                        modifyTVar esInAction (Set.delete $ actionId action)
+                        modifyTVar esCompleted (+1)
+                        case eres of
+                            Left err -> modifyTVar esExceptions (err:)
+                            Right () ->
                                 let dropDep a = a { actionDeps = Set.delete (actionId action) $ actionDeps a }
-                                modifyTVar esActions $ map dropDep
-                            restore loop
+                                 in modifyTVar esActions $ map dropDep
+                    restore loop
diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs
@@ -333,8 +333,15 @@ executePlan' plan ee@ExecuteEnv {..} = do
             (planTasks plan)
             (planFinals plan)
     threads <- asks $ configJobs . getConfig
+    let keepGoing =
+            case boptsKeepGoing eeBuildOpts of
+                Just kg -> kg
+                Nothing ->
+                    case boptsFinalAction eeBuildOpts of
+                        DoNothing -> False
+                        _ -> True
     terminal <- asks getTerminal
-    errs <- liftIO $ runActions threads actions $ \doneVar -> do
+    errs <- liftIO $ runActions threads keepGoing actions $ \doneVar -> do
         let total = length actions
             loop prev
                 | prev == total =

diff --git a/src/Stack/Build/Types.hs b/src/Stack/Build/Types.hs
@@ -297,6 +297,8 @@ data BuildOpts =
             -- suites.
             ,boptsFileWatch :: !Bool
             -- ^ Watch files for changes and automatically rebuild
+            ,boptsKeepGoing :: !(Maybe Bool)
+            -- ^ Keep building/running after failure
             }
   deriving (Show)
 
@@ -318,6 +320,7 @@ defaultBuildOpts = BuildOpts
     , boptsOnlySnapshot = False
     , boptsCoverage = False
     , boptsFileWatch = False
+    , boptsKeepGoing = Nothing
     }
 
 -- | Run a Setup.hs action after building a package, before installing.

diff --git a/src/main/Main.hs b/src/main/Main.hs
@@ -667,7 +667,7 @@ buildOpts cmd = fmap process $
             BuildOpts <$> target <*> libProfiling <*> exeProfiling <*>
             optimize <*> haddock <*> haddockDeps <*> finalAction <*> dryRun <*> ghcOpts <*>
             flags <*> installExes <*> preFetch <*> testArgs <*> onlySnapshot <*> coverage <*>
-            fileWatch'
+            fileWatch' <*> keepGoing
   where process bopts =
             if boptsCoverage bopts
                then bopts { boptsExeProfile = True
@@ -751,6 +751,11 @@ buildOpts cmd = fmap process $
             (long "file-watch" <>
              help "Watch for changes in local files and automatically rebuild")
 
+        keepGoing = maybeBoolFlags
+            "keep-going"
+            "continue running after a step fails (default: false for build, true for test/bench)"
+            idm
+
 -- | Parser for docker cleanup arguments.
 dockerCleanupOpts :: Parser Docker.CleanupOpts
 dockerCleanupOpts =