Flag to avoid rerunning tests that haven't changed #451

ChangeLog.md

@@ -6,6 +6,7 @@
 * exec style commands accept the `--package` option (see [Reddit discussion](http://www.reddit.com/r/haskell/comments/3bd66h/stack_runghc_turtle_as_haskell_script_solution/))
 * `stack upload` without arguments doesn't do anything [#439](https://github.com/commercialhaskell/stack/issues/439)
 * Print latest version of packages on conflicts [#450](https://github.com/commercialhaskell/stack/issues/450)
+* Flag to avoid rerunning tests that haven't changed [#451](https://github.com/commercialhaskell/stack/issues/451)
 
 ## 0.1.1.0
 

src/Stack/Build/Cache.hs

@@ -18,6 +18,9 @@ module Stack.Build.Cache
     , writeBuildCache
     , writeConfigCache
     , writeCabalMod
+    , setTestSuccess
+    , unsetTestSuccess
+    , checkTestSuccess
     ) where
 
 import           Control.Exception.Enclosed (catchIO, handleIO, tryIO)
@@ -32,7 +35,7 @@ import qualified Data.ByteString as S
 import qualified Data.ByteString.Lazy as L
 import           Data.Map (Map)
 import qualified Data.Map as Map
-import           Data.Maybe (catMaybes, mapMaybe)
+import           Data.Maybe (catMaybes, fromMaybe, mapMaybe)
 import qualified Data.Set as Set
 import           GHC.Generics (Generic)
 import           Path
@@ -228,3 +231,32 @@ getPackageFileModTimes pkg cabalfp = do
                        if isDoesNotExistError e
                            then return Nothing
                            else throwM e))
+
+-- | Mark a test suite as having succeeded
+setTestSuccess :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env)
+               => Path Abs Dir
+               -> m ()
+setTestSuccess dir =
+    writeCache
+        dir
+        testSuccessFile
+        True
+
+-- | Mark a test suite as not having succeeded
+unsetTestSuccess :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env)
+                 => Path Abs Dir
+                 -> m ()
+unsetTestSuccess dir =
+    writeCache
+        dir
+        testSuccessFile
+        False
+
+-- | Check if the test suite already passed
+checkTestSuccess :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env)
+                 => Path Abs Dir
+                 -> m Bool
+checkTestSuccess dir =
+    liftM
+        (fromMaybe False)
+        (tryGetCache testSuccessFile dir)

src/Stack/Build/Execute.hs

@@ -124,7 +124,7 @@ printPlan finalAction plan = do
             case finalAction of
                 DoNothing -> Nothing
                 DoBenchmarks -> Just "benchmark"
-                DoTests -> Just "test"
+                DoTests _ -> Just "test"
     case mfinalLabel of
         Nothing -> return ()
         Just finalLabel -> do
@@ -393,7 +393,7 @@ toActions runInBase ee (mbuild, mfinal) =
     mfunc =
         case boptsFinalAction $ eeBuildOpts ee of
             DoNothing -> Nothing
-            DoTests -> Just (singleTest, checkTest)
+            DoTests rerunTests -> Just (singleTest rerunTests, checkTest)
             DoBenchmarks -> Just (singleBench, checkBench)
 
     checkTest task =
@@ -671,11 +671,12 @@ singleBuild ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} =
             Set.empty
 
 singleTest :: M env m
-           => ActionContext
+           => Bool -- ^ rerun tests?
+           -> ActionContext
            -> ExecuteEnv
            -> Task
            -> m ()
-singleTest ac ee task =
+singleTest rerunTests ac ee task =
     withSingleContext ac ee task $ \package cabalfp pkgDir cabal announce console mlogFile -> do
         (_cache, neededConfig) <- ensureConfig pkgDir ee task (announce "configure (test)") cabal cabalfp ["--enable-tests"]
         config <- asks getConfig
@@ -695,102 +696,117 @@ singleTest ac ee task =
 
         when needBuild $ do
             announce "build (test)"
+            unsetTestSuccess pkgDir
             fileModTimes <- getPackageFileModTimes package cabalfp
             writeBuildCache pkgDir fileModTimes
             cabal (console && configHideTHLoading config) $ "build" : components
 
-        bconfig <- asks getBuildConfig
-        buildDir <- distDirFromDir pkgDir
-        hpcDir <- hpcDirFromDir pkgDir
-        when needHpc (createTree hpcDir)
-        let dotHpcDir = pkgDir </> dotHpc
-            exeExtension =
-                case configPlatform $ getConfig bconfig of
-                    Platform _ Windows -> ".exe"
-                    _ -> ""
-
-        errs <- liftM Map.unions $ forM testsToRun $ \testName -> do
-            nameDir <- parseRelDir $ T.unpack testName
-            nameExe <- parseRelFile $ T.unpack testName ++ exeExtension
-            nameTix <- liftM (pkgDir </>) $ parseRelFile $ T.unpack testName ++ ".tix"
-            let exeName = buildDir </> $(mkRelDir "build") </> nameDir </> nameExe
-            exists <- fileExists exeName
-            menv <- liftIO $ configEnvOverride config EnvSettings
-                { esIncludeLocals = taskLocation task == Local
-                , esIncludeGhcPackagePath = True
-                , esStackExe = True
-                }
-            if exists
-                then do
-                    -- We clear out the .tix files before doing a run.
-                    when needHpc $ do
-                        tixexists <- fileExists nameTix
-                        when tixexists $
-                            $logWarn ("Removing HPC file " <> T.pack (toFilePath nameTix))
-                        removeFileIfExists nameTix
-
-                    let args = boptsTestArgs (eeBuildOpts ee)
-                        argsDisplay =
-                            case args of
-                              [] -> ""
-                              _ -> ", args: " <> T.intercalate " " (map showProcessArgDebug args)
-                    announce $ "test (suite: " <> testName <> argsDisplay <> ")"
-                    let cp = (proc (toFilePath exeName) args)
-                            { cwd = Just $ toFilePath pkgDir
-                            , Process.env = envHelper menv
-                            , std_in = CreatePipe
-                            , std_out =
-                                case mlogFile of
-                                    Nothing -> Inherit
-                                    Just (_, h) -> UseHandle h
-                            , std_err =
-                                case mlogFile of
-                                    Nothing -> Inherit
-                                    Just (_, h) -> UseHandle h
-                            }
-
-                    -- Use createProcess_ to avoid the log file being closed afterwards
-                    (Just inH, Nothing, Nothing, ph) <- liftIO $ createProcess_ "singleBuild.runTests" cp
-                    liftIO $ hClose inH
-                    ec <- liftIO $ waitForProcess ph
-                    -- Move the .tix file out of the package directory
-                    -- into the hpc work dir, for tidiness.
-                    when needHpc $
-                        moveFileIfExists nameTix hpcDir
-                    return $ case ec of
-                        ExitSuccess -> Map.empty
-                        _ -> Map.singleton testName $ Just ec
+        toRun <-
+            if rerunTests
+                then return True
                 else do
-                    $logError $ T.concat
-                        [ "Test suite "
-                        , testName
-                        , " executable not found for "
-                        , T.pack $ packageNameString $ packageName package
-                        ]
-                    return $ Map.singleton testName Nothing
-        when needHpc $ do
-            createTree (hpcDir </> dotHpc)
-            exists <- dirExists dotHpcDir
-            when exists $ do
-                copyDirectoryRecursive dotHpcDir (hpcDir </> dotHpc)
-                removeTree dotHpcDir
-            (_,files) <- listDirectory hpcDir
-            let tixes =
-                    filter (isSuffixOf ".tix" . toFilePath . filename) files
-            generateHpcReport pkgDir hpcDir (hpcDir </> dotHpc) tixes
-
-        bs <- liftIO $
-            case mlogFile of
-                Nothing -> return ""
-                Just (logFile, h) -> do
-                    hClose h
-                    S.readFile $ toFilePath logFile
-
-        unless (Map.null errs) $ throwM $ TestSuiteFailure
-            (taskProvides task)
-            errs
-            (fmap fst mlogFile)
-            bs
+                    success <- checkTestSuccess pkgDir
+                    if success
+                        then do
+                            unless (null testsToRun) $ announce "skipping already passed test"
+                            return False
+                        else return True
+
+        when toRun $ do
+            bconfig <- asks getBuildConfig
+            buildDir <- distDirFromDir pkgDir
+            hpcDir <- hpcDirFromDir pkgDir
+            when needHpc (createTree hpcDir)
+            let dotHpcDir = pkgDir </> dotHpc
+                exeExtension =
+                    case configPlatform $ getConfig bconfig of
+                        Platform _ Windows -> ".exe"
+                        _ -> ""
+
+            errs <- liftM Map.unions $ forM testsToRun $ \testName -> do
+                nameDir <- parseRelDir $ T.unpack testName
+                nameExe <- parseRelFile $ T.unpack testName ++ exeExtension
+                nameTix <- liftM (pkgDir </>) $ parseRelFile $ T.unpack testName ++ ".tix"
+                let exeName = buildDir </> $(mkRelDir "build") </> nameDir </> nameExe
+                exists <- fileExists exeName
+                menv <- liftIO $ configEnvOverride config EnvSettings
+                    { esIncludeLocals = taskLocation task == Local
+                    , esIncludeGhcPackagePath = True
+                    , esStackExe = True
+                    }
+                if exists
+                    then do
+                        -- We clear out the .tix files before doing a run.
+                        when needHpc $ do
+                            tixexists <- fileExists nameTix
+                            when tixexists $
+                                $logWarn ("Removing HPC file " <> T.pack (toFilePath nameTix))
+                            removeFileIfExists nameTix
+
+                        let args = boptsTestArgs (eeBuildOpts ee)
+                            argsDisplay =
+                                case args of
+                                  [] -> ""
+                                  _ -> ", args: " <> T.intercalate " " (map showProcessArgDebug args)
+                        announce $ "test (suite: " <> testName <> argsDisplay <> ")"
+                        let cp = (proc (toFilePath exeName) args)
+                                { cwd = Just $ toFilePath pkgDir
+                                , Process.env = envHelper menv
+                                , std_in = CreatePipe
+                                , std_out =
+                                    case mlogFile of
+                                        Nothing -> Inherit
+                                        Just (_, h) -> UseHandle h
+                                , std_err =
+                                    case mlogFile of
+                                        Nothing -> Inherit
+                                        Just (_, h) -> UseHandle h
+                                }
+
+                        -- Use createProcess_ to avoid the log file being closed afterwards
+                        (Just inH, Nothing, Nothing, ph) <- liftIO $ createProcess_ "singleBuild.runTests" cp
+                        liftIO $ hClose inH
+                        ec <- liftIO $ waitForProcess ph
+                        -- Move the .tix file out of the package directory
+                        -- into the hpc work dir, for tidiness.
+                        when needHpc $
+                            moveFileIfExists nameTix hpcDir
+                        return $ case ec of
+                            ExitSuccess -> Map.empty
+                            _ -> Map.singleton testName $ Just ec
+                    else do
+                        $logError $ T.concat
+                            [ "Test suite "
+                            , testName
+                            , " executable not found for "
+                            , T.pack $ packageNameString $ packageName package
+                            ]
+                        return $ Map.singleton testName Nothing
+            when needHpc $ do
+                createTree (hpcDir </> dotHpc)
+                exists <- dirExists dotHpcDir
+                when exists $ do
+                    copyDirectoryRecursive dotHpcDir (hpcDir </> dotHpc)
+                    removeTree dotHpcDir
+                (_,files) <- listDirectory hpcDir
+                let tixes =
+                        filter (isSuffixOf ".tix" . toFilePath . filename) files
+                generateHpcReport pkgDir hpcDir (hpcDir </> dotHpc) tixes
+
+            bs <- liftIO $
+                case mlogFile of
+                    Nothing -> return ""
+                    Just (logFile, h) -> do
+                        hClose h
+                        S.readFile $ toFilePath logFile
+
+            unless (Map.null errs) $ throwM $ TestSuiteFailure
+                (taskProvides task)
+                errs
+                (fmap fst mlogFile)
+                bs
+
+            setTestSuccess pkgDir
 
 -- | Determine the tests to be run based on the list of components.
 compareTestsComponents :: [Text] -- ^ components

src/Stack/Build/Source.hs

@@ -190,7 +190,10 @@ loadLocals bopts latestVersion = do
                 , packageConfigPlatform = configPlatform $ getConfig bconfig
                 }
             configFinal = config
-                { packageConfigEnableTests = wanted && boptsFinalAction bopts == DoTests
+                { packageConfigEnableTests =
+                    case boptsFinalAction bopts of
+                        DoTests _ -> wanted
+                        _ -> False
                 , packageConfigEnableBenchmarks = wanted && boptsFinalAction bopts == DoBenchmarks
                 }
         pkg <- readPackage config cabalfp

src/Stack/Build/Types.hs

@@ -320,9 +320,10 @@ defaultBuildOpts = BuildOpts
 -- | Run a Setup.hs action after building a package, before installing.
 data FinalAction
   = DoTests
+      Bool -- rerun tests which already passed?
   | DoBenchmarks
   | DoNothing
-  deriving (Eq,Bounded,Enum,Show)
+  deriving (Eq,Show)
 
 -- | Package dependency oracle.
 newtype PkgDepsOracle =

src/Stack/Constants.hs

@@ -19,6 +19,7 @@ module Stack.Constants
     ,configCacheFile
     ,configCabalMod
     ,buildCacheFile
+    ,testSuccessFile
     ,stackProgName
     ,wiredInPackages
     ,cabalPackageName
@@ -108,6 +109,15 @@ buildCacheFile dir = do
         (</> $(mkRelFile "stack-build-cache"))
         (distDirFromDir dir)
 
+-- | The filename used to mark tests as having succeeded
+testSuccessFile :: (MonadThrow m, MonadReader env m, HasPlatform env,HasEnvConfig env)
+                => Path Abs Dir -- ^ Package directory
+                -> m (Path Abs File)
+testSuccessFile dir =
+    liftM
+        (</> $(mkRelFile "stack-test-success"))
+        (distDirFromDir dir)
+
 -- | The filename used for dirtiness check of config.
 configCacheFile :: (MonadThrow m, MonadReader env m, HasPlatform env,HasEnvConfig env)
                 => Path Abs Dir      -- ^ Package directory.

src/main/Main.hs

@@ -101,8 +101,13 @@ main =
                         (buildOpts Build)
              addCommand "test"
                         "Build and test the project(s) in this directory/configuration"
-                        (buildCmd DoTests)
-                        (buildOpts Test)
+                        (\(rerun, bopts) -> buildCmd (DoTests rerun) bopts)
+                        ((,)
+                            <$> boolFlags True
+                                "rerun-tests"
+                                "running already successful tests"
+                                idm
+                            <*> (buildOpts Test))
              addCommand "bench"
                         "Build and benchmark the project(s) in this directory/configuration"
                         (buildCmd DoBenchmarks)