Skip to content

Commit

Permalink
Use main build code for tests/benchmarks #1166
Browse files Browse the repository at this point in the history
  • Loading branch information
@mgsloan
mgsloan committed Nov 4, 2015
1 parent ec8a4fa commit e54d581
Show file tree
Hide file tree
Showing 3 changed files with 56 additions and 146 deletions.
1 change: 1 addition & 0 deletions src/Control/Concurrent/Execute.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -24,6 +24,7 @@ import Stack.Types

data ActionType
= ATBuild
| ATBuildFinal
| ATFinal
deriving (Show, Eq, Ord)
data ActionId = ActionId !PackageIdentifier !ActionType
Expand Down
64 changes: 0 additions & 64 deletions src/Stack/Build/Cache.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -21,12 +21,6 @@ module Stack.Build.Cache
, setTestSuccess
, unsetTestSuccess
, checkTestSuccess
, setTestBuilt
, unsetTestBuilt
, checkTestBuilt
, setBenchBuilt
, unsetBenchBuilt
, checkBenchBuilt
, writePrecompiledCache
, readPrecompiledCache
) where
Expand Down Expand Up @@ -229,64 +223,6 @@ checkTestSuccess dir =
(fromMaybe False)
(tryGetCache testSuccessFile dir)

-- | Mark a test suite as having built
setTestBuilt :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env)
=> Path Abs Dir
-> m ()
setTestBuilt dir =
writeCache
dir
testBuiltFile
True

-- | Mark a test suite as not having built
unsetTestBuilt :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env)
=> Path Abs Dir
-> m ()
unsetTestBuilt dir =
writeCache
dir
testBuiltFile
False

-- | Check if the test suite already built
checkTestBuilt :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env)
=> Path Abs Dir
-> m Bool
checkTestBuilt dir =
liftM
(fromMaybe False)
(tryGetCache testBuiltFile dir)

-- | Mark a bench suite as having built
setBenchBuilt :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env)
=> Path Abs Dir
-> m ()
setBenchBuilt dir =
writeCache
dir
benchBuiltFile
True

-- | Mark a bench suite as not having built
unsetBenchBuilt :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env)
=> Path Abs Dir
-> m ()
unsetBenchBuilt dir =
writeCache
dir
benchBuiltFile
False

-- | Check if the bench suite already built
checkBenchBuilt :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env)
=> Path Abs Dir
-> m Bool
checkBenchBuilt dir =
liftM
(fromMaybe False)
(tryGetCache benchBuiltFile dir)

--------------------------------------
-- Precompiled Cache
--
Expand Down
137 changes: 55 additions & 82 deletions src/Stack/Build/Execute.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -37,10 +37,10 @@ import qualified Data.ByteString.Char8 as S8
import Data.Conduit
import qualified Data.Conduit.Binary as CB
import qualified Data.Conduit.List as CL
import Data.Foldable (forM_)
import Data.Foldable (forM_, any)
import Data.Function
import Data.IORef.RunOnce (runOnce)
import Data.List
import Data.List hiding (any)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe
Expand All @@ -52,6 +52,7 @@ import qualified Data.Streaming.Process as Process
import Data.Traversable (forM)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8)
import Data.Time.Clock (getCurrentTime)
import Data.Word8 (_colon)
import Distribution.System (OS (Windows),
Expand All @@ -61,7 +62,7 @@ import Language.Haskell.TH as TH (location)
import Network.HTTP.Client.Conduit (HasHttpManager)
import Path
import Path.IO
import Prelude hiding (FilePath, writeFile)
import Prelude hiding (FilePath, writeFile, any)
import Stack.Build.Cache
import Stack.Build.Haddock
import Stack.Build.Installed
Expand Down Expand Up @@ -532,17 +533,22 @@ toActions installedMap runInBase ee (mbuild, mfinal) =
{ actionId = ActionId taskProvides ATBuild
, actionDeps =
(Set.map (\ident -> ActionId ident ATBuild) (tcoMissing taskConfigOpts))
, actionDo = \ac -> runInBase $ singleBuild runInBase ac ee task installedMap
, actionDo = \ac -> runInBase $ singleBuild runInBase ac ee task installedMap False
}
]
afinal =
case mfinal of
Nothing -> []
Just task@Task {..} ->
[ Action
{ actionId = ActionId taskProvides ATFinal
, actionDeps = addBuild taskProvides $
{ actionId = ActionId taskProvides ATBuildFinal
, actionDeps = addBuild taskProvides
(Set.map (\ident -> ActionId ident ATBuild) (tcoMissing taskConfigOpts))
, actionDo = \ac -> runInBase $ singleBuild runInBase ac ee task installedMap True
}
, Action
{ actionId = ActionId taskProvides ATFinal
, actionDeps = Set.singleton (ActionId taskProvides ATBuildFinal)
, actionDo = \ac -> runInBase $ do
let comps = taskComponents task
tests = testComponents comps
Expand All @@ -554,12 +560,10 @@ toActions installedMap runInBase ee (mbuild, mfinal) =
singleBench runInBase beopts ac ee task installedMap
}
]
where
addBuild ident =
case mbuild of
Nothing -> id
Just _ -> Set.insert $ ActionId ident ATBuild

addBuild ident =
case mbuild of
Nothing -> id
Just _ -> Set.insert $ ActionId ident ATBuild
bopts = eeBuildOpts ee
topts = boptsTestOpts bopts
beopts = boptsBenchmarkOpts bopts
Expand Down Expand Up @@ -886,9 +890,10 @@ singleBuild :: M env m
-> ExecuteEnv
-> Task
-> InstalledMap
-> Bool
-> m ()
singleBuild runInBase ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} installedMap = do
(allDepsMap, cache) <- getConfigCache ee task installedMap False False
singleBuild runInBase ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} installedMap isFinalBuild = do
(allDepsMap, cache) <- getConfigCache ee task installedMap enableTests enableBenchmarks
mprecompiled <- getPrecompiled cache
minstalled <-
case mprecompiled of
Expand All @@ -903,10 +908,20 @@ singleBuild runInBase ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} in
pname = packageIdentifierName taskProvides
shouldHaddockPackage' = shouldHaddockPackage eeBuildOpts eeWanted pname
doHaddock package = shouldHaddockPackage' &&
not isFinalBuild &&
-- Works around haddock failing on bytestring-builder since it has no modules
-- when bytestring is new enough.
packageHasExposedModules package

enableTests = isFinalBuild && any isCTest (taskComponents task)
enableBenchmarks = isFinalBuild && any isCBench (taskComponents task)
annSuffix =
case (enableTests, enableBenchmarks) of
(False, False) -> ""
(True, False) -> " (test)"
(False, True) -> " (bench)"
(True, True) -> " (test + bench)"

getPrecompiled cache =
case taskLocation task of
Snap | not shouldHaddockPackage' -> do
Expand Down Expand Up @@ -969,7 +984,7 @@ singleBuild runInBase ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} in

realConfigAndBuild cache allDepsMap = withSingleContext runInBase ac ee task (Just allDepsMap) Nothing
$ \package cabalfp pkgDir cabal announce console _mlogFile -> do
_neededConfig <- ensureConfig cache pkgDir ee (announce "configure") cabal cabalfp
_neededConfig <- ensureConfig cache pkgDir ee (announce ("configure" <> annSuffix)) cabal cabalfp

if boptsOnlyConfigure eeBuildOpts
then return Nothing
Expand All @@ -980,18 +995,20 @@ singleBuild runInBase ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} in

markExeNotInstalled (taskLocation task) taskProvides
case taskType of
TTLocal lp -> writeBuildCache pkgDir $ lpNewBuildCache lp
TTLocal lp -> do
when enableTests $ unsetTestSuccess pkgDir
writeBuildCache pkgDir $ lpNewBuildCache lp
TTUpstream _ _ -> return ()

() <- announce "build"
() <- announce ("build" <> annSuffix)
config <- asks getConfig
extraOpts <- extraBuildOptions eeBuildOpts
preBuildTime <- modTime <$> liftIO getCurrentTime
cabal (console && configHideTHLoading config) $
(case taskType of
TTLocal lp -> concat
[ ["build"]
, ["lib:" ++ packageNameString (packageName package)
cabal (console && configHideTHLoading config) $ ("build" :) $ (++ extraOpts) $
case (taskType, isFinalBuild) of
-- Normal build
(TTLocal lp, False) -> concat
[ ["lib:" ++ packageNameString (packageName package)
-- TODO: get this information from target parsing instead,
-- which will allow users to turn off library building if
-- desired
Expand All @@ -1004,7 +1021,12 @@ singleBuild runInBase ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} in
-- extra-deps).
else packageExes package
]
TTUpstream _ _ -> ["build"]) ++ extraOpts
-- Tests / benchmarks build
(TTLocal lp, True) ->
map (T.unpack . decodeUtf8 . renderComponent) $
Set.toList $
Set.filter (\c -> isCTest c || isCBench c) (lpComponents lp)
(TTUpstream{}, _) -> []
checkForUnlistedFiles taskType preBuildTime pkgDir

when (doHaddock package) $ do
Expand All @@ -1025,7 +1047,7 @@ singleBuild runInBase ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} in
cabal False (concat [["haddock", "--html", "--hoogle", "--html-location=../$pkg-$version/"]
,sourceFlag])

withMVar eeInstallLock $ \() -> do
unless isFinalBuild $ withMVar eeInstallLock $ \() -> do
announce "copy/register"
cabal False ["copy"]
when (packageHasLibrary package) $ cabal False ["register"]
Expand Down Expand Up @@ -1115,37 +1137,12 @@ singleTest :: M env m
-> InstalledMap
-> m ()
singleTest runInBase topts testsToRun ac ee task installedMap = do
(allDepsMap, cache) <- getConfigCache ee task installedMap True False
withSingleContext runInBase ac ee task (Just allDepsMap) (Just "test") $ \package cabalfp pkgDir cabal announce console mlogFile -> do
neededConfig <- ensureConfig cache pkgDir ee (announce "configure (test)") cabal cabalfp
-- FIXME: Since this doesn't use cabal, we should be able to avoid using a
-- fullblown 'withSingleContext'.
(allDepsMap, _cache) <- getConfigCache ee task installedMap True False
withSingleContext runInBase ac ee task (Just allDepsMap) (Just "test") $ \package _cabalfp pkgDir _cabal announce _console mlogFile -> do
config <- asks getConfig

testBuilt <- checkTestBuilt pkgDir

let needBuild = neededConfig ||
(case taskType task of
TTLocal lp ->
case lpDirtyFiles lp of
Just _ -> True
Nothing -> False
_ -> assert False True) ||
not testBuilt
needHpc = toCoverage topts
components = map (T.unpack . T.append "test:") testsToRun

when needBuild $ do
announce "build (test)"
unsetTestBuilt pkgDir
unsetTestSuccess pkgDir
case taskType task of
TTLocal lp -> writeBuildCache pkgDir $ lpNewBuildCache lp
TTUpstream _ _ -> assert False $ return ()
extraOpts <- extraBuildOptions (eeBuildOpts ee)
preBuildTime <- modTime <$> liftIO getCurrentTime
cabal (console && configHideTHLoading config) $
"build" : (components ++ extraOpts)
checkForUnlistedFiles (taskType task) preBuildTime pkgDir
setTestBuilt pkgDir
let needHpc = toCoverage topts

toRun <-
if toDisableRun topts
Expand Down Expand Up @@ -1248,8 +1245,6 @@ singleTest runInBase topts testsToRun ac ee task installedMap = do
(fmap fst mlogFile)
bs

setTestSuccess pkgDir

singleBench :: M env m
=> (m () -> IO ())
-> BenchmarkOpts
Expand All @@ -1259,32 +1254,10 @@ singleBench :: M env m
-> InstalledMap
-> m ()
singleBench runInBase beopts ac ee task installedMap = do
(allDepsMap, cache) <- getConfigCache ee task installedMap False True
withSingleContext runInBase ac ee task (Just allDepsMap) (Just "bench") $ \_package cabalfp pkgDir cabal announce console _mlogFile -> do
neededConfig <- ensureConfig cache pkgDir ee (announce "configure (benchmarks)") cabal cabalfp

benchBuilt <- checkBenchBuilt pkgDir

let needBuild = neededConfig ||
(case taskType task of
TTLocal lp ->
case lpDirtyFiles lp of
Just _ -> True
Nothing -> False
_ -> assert False True) ||
not benchBuilt
when needBuild $ do
announce "build (benchmarks)"
unsetBenchBuilt pkgDir
case taskType task of
TTLocal lp -> writeBuildCache pkgDir $ lpNewBuildCache lp
TTUpstream _ _ -> assert False $ return ()
config <- asks getConfig
extraOpts <- extraBuildOptions (eeBuildOpts ee)
preBuildTime <- modTime <$> liftIO getCurrentTime
cabal (console && configHideTHLoading config) ("build" : extraOpts)
checkForUnlistedFiles (taskType task) preBuildTime pkgDir
setBenchBuilt pkgDir
-- FIXME: Since this doesn't use cabal, we should be able to avoid using a
-- fullblown 'withSingleContext'.
(allDepsMap, _cache) <- getConfigCache ee task installedMap False True
withSingleContext runInBase ac ee task (Just allDepsMap) (Just "bench") $ \_package _cabalfp _pkgDir cabal announce _console _mlogFile -> do
let args = maybe []
((:[]) . ("--benchmark-options=" <>))
(beoAdditionalArgs beopts)
Expand Down

0 comments on commit e54d581

Please sign in to comment.