@@ -19,11 +19,12 @@ import qualified Data.Map as Map
1919import Data.NonNull (fromNullable)
2020import Filesystem (canonicalizePath, createTree,
2121 getWorkingDirectory, isDirectory,
22− removeTree, rename)
22+ removeTree, rename, isFile, removeFile)
2323import Filesystem.Path (parent)
2424import qualified Filesystem.Path as F
2525import Stackage.BuildConstraints
2626import Stackage.BuildPlan
27+import Stackage.GhcPkg
2728import Stackage.PackageDescription
2829import Stackage.Prelude hiding (pi)
2930import System.Directory (findExecutable)
@@ -135,6 +136,10 @@ pbLibDir pb = pbInstallDest pb </> "lib"
135136pbDataDir pb = pbInstallDest pb </> "share"
136137pbDocDir pb = pbInstallDest pb </> "doc"
137138
139+-- | Directory keeping previous result info
140+pbPrevResDir :: PerformBuild -> FilePath
141+pbPrevResDir pb = pbInstallDest pb </> "prevres"
142+
138143performBuild :: PerformBuild -> IO [Text]
139144performBuild pb = do
140145 cwd <- getWorkingDirectory
@@ -162,12 +167,13 @@ performBuild' pb@PerformBuild {..} = withBuildDir $ \builddir -> do
162167 $ \ClosedStream Inherited Inherited -> return ()
163168
164169 let removeTree' fp = whenM (isDirectory fp) (removeTree fp)
165− mapM_ removeTree' [pbInstallDest, pbLogDir]
170+ removeTree' pbLogDir
166171
167− forM_ (pbDatabase pb) $ \db -> do
168− createTree $ parent db
169− withCheckedProcess (proc "ghc-pkg" ["init", fpToString db])
170− $ \ClosedStream Inherited Inherited -> return ()
172+ forM_ (pbDatabase pb) $ \db ->
173+ unlessM (isFile $ db </> "package.cache") $ do
174+ createTree $ parent db
175+ withCheckedProcess (proc "ghc-pkg" ["init", fpToString db])
176+ $ \ClosedStream Inherited Inherited -> return ()
171177 pbLog $ encodeUtf8 "Copying built-in Haddocks\n"
172178 copyBuiltInHaddocks (pbDocDir pb)
173179
@@ -187,7 +193,15 @@ performBuild' pb@PerformBuild {..} = withBuildDir $ \builddir -> do
187193 env <- getEnvironment
188194 haddockFiles <- newTVarIO mempty
189195
190− forM_ packageMap $ \pi -> void $ async $ singleBuild pb SingleBuild
196+ registeredPackages <- setupPackageDatabase
197+ (pbDatabase pb)
198+ (pbDocDir pb)
199+ pbLog
200+ (ppVersion <$> bpPackages pbPlan)
201+ (deletePreviousResults pb)
202+
203+ forM_ packageMap $ \pi -> void $ async $ singleBuild pb registeredPackages
204+ SingleBuild
191205 { sbSem = sem
192206 , sbErrsVar = errsVar
193207 , sbWarningsVar = warningsVar
@@ -249,8 +263,10 @@ data SingleBuild = SingleBuild
249263 , sbHaddockFiles :: TVar (Map Text FilePath) -- ^ package-version, .haddock file
250264 }
251265
252−singleBuild :: PerformBuild -> SingleBuild -> IO ()
253−singleBuild pb@PerformBuild {..} SingleBuild {..} =
266+singleBuild :: PerformBuild
267+ -> Set PackageName -- ^ registered packages
268+ -> SingleBuild -> IO ()
269+singleBuild pb@PerformBuild {..} registeredPackages SingleBuild {..} =
254270 withCounter sbActive
255271 $ handle updateErrs
256272 $ (`finally` void (atomically $ tryPutTMVar (piResult sbPackageInfo) False))
@@ -262,11 +278,13 @@ singleBuild pb@PerformBuild {..} SingleBuild {..} =
262278 let wfd comps =
263279 waitForDeps sbToolMap sbPackageMap comps pbPlan sbPackageInfo
264280 . withTSem sbSem
265− wfd libComps buildLibrary
281+ withUnpacked <- wfd libComps buildLibrary
266282
267− wfd testComps runTests
283+ wfd testComps (runTests withUnpacked)
268284
269− name = display $ piName sbPackageInfo
285+ pname = piName sbPackageInfo
286+ pident = PackageIdentifier pname (ppVersion $ piPlan sbPackageInfo)
287+ name = display pname
270288 namever = concat
271289 [ name
272290 , "-"
@@ -335,19 +353,37 @@ singleBuild pb@PerformBuild {..} SingleBuild {..} =
335353 buildLibrary = wf libOut $ \outH -> do
336354 let run a b = do when pbVerbose $ log' (unwords (a : b))
337355 runChild outH a b
338− log' $ "Unpacking " ++ namever
339− runParent outH "cabal" ["unpack", namever]
340−
341− log' $ "Configuring " ++ namever
342− run "cabal" $ "configure" : configArgs
343356
344− log' $ "Building " ++ namever
345− run "cabal" ["build"]
346−
347− log' $ "Copying/registering " ++ namever
348− run "cabal" ["copy"]
349− withMVar sbRegisterMutex $ const $
350− run "cabal" ["register"]
357+ isUnpacked <- newIORef False
358+ let withUnpacked inner = do
359+ unlessM (readIORef isUnpacked) $ do
360+ log' $ "Unpacking " ++ namever
361+ runParent outH "cabal" ["unpack", namever]
362+ writeIORef isUnpacked True
363+ inner
364+
365+ isConfiged <- newIORef False
366+ let withConfiged inner = withUnpacked $ do
367+ unlessM (readIORef isConfiged) $ do
368+ log' $ "Configuring " ++ namever
369+ run "cabal" $ "configure" : configArgs
370+ writeIORef isConfiged True
371+ inner
372+
373+ prevBuildResult <- getPreviousResult pb Build pident
374+ unless (prevBuildResult == PRSuccess) $ withConfiged $ do
375+ assert (pname `notMember` registeredPackages) $ do
376+ deletePreviousResults pb pident
377+
378+ log' $ "Building " ++ namever
379+ run "cabal" ["build"]
380+
381+ log' $ "Copying/registering " ++ namever
382+ run "cabal" ["copy"]
383+ withMVar sbRegisterMutex $ const $
384+ run "cabal" ["register"]
385+
386+ savePreviousResult pb Build pident True
351387
352388 -- Even if the tests later fail, we can allow other libraries to build
353389 -- on top of our successful results
@@ -357,7 +393,11 @@ singleBuild pb@PerformBuild {..} SingleBuild {..} =
357393 -- dependency's haddocks before this finishes
358394 atomically $ putTMVar (piResult sbPackageInfo) True
359395
360− when (pbEnableHaddock && pcHaddocks /= Don'tBuild && not (null $ sdModules $ ppDesc $ piPlan sbPackageInfo)) $ do
396+ prevHaddockResult <- getPreviousResult pb Haddock pident
397+ let needHaddock = pbEnableHaddock
398+ && checkPrevResult prevHaddockResult pcHaddocks
399+ && not (null $ sdModules $ ppDesc $ piPlan sbPackageInfo)
400+ when needHaddock $ withConfiged $ do
361401 log' $ "Haddocks " ++ namever
362402 hfs <- readTVarIO sbHaddockFiles
363403 let hfsOpts = flip map (mapToList hfs) $ \(pkgVer, hf) -> concat
@@ -392,15 +432,21 @@ singleBuild pb@PerformBuild {..} SingleBuild {..} =
392432 $ modifyTVar sbHaddockFiles
393433 $ insertMap namever newPath
394434
435+ savePreviousResult pb Haddock pident $ either (const False) (const True) eres
395436 case (eres, pcHaddocks) of
396437 (Left e, ExpectSuccess) -> throwM e
397438 (Right (), ExpectFailure) -> warn $ namever ++ ": unexpected Haddock success"
398439 _ -> return ()
399440
400− runTests = wf testOut $ \outH -> do
441+ return withUnpacked
442+
443+ runTests withUnpacked = wf testOut $ \outH -> do
401444 let run = runChild outH
402445
403− when (pbEnableTests && pcTests /= Don'tBuild) $ do
446+ prevTestResult <- getPreviousResult pb Test pident
447+ let needTest = pbEnableTests
448+ && checkPrevResult prevTestResult pcTests
449+ when needTest $ withUnpacked $ do
404450 log' $ "Test configure " ++ namever
405451 run "cabal" $ "configure" : "--enable-tests" : configArgs
406452
@@ -411,6 +457,7 @@ singleBuild pb@PerformBuild {..} SingleBuild {..} =
411457 log' $ "Test run " ++ namever
412458 run "cabal" ["test", "--log=" ++ fpToText testRunOut]
413459
460+ savePreviousResult pb Test pident $ either (const False) (const True) eres
414461 case (eres, pcTests) of
415462 (Left e, ExpectSuccess) -> throwM e
416463 (Right (), ExpectFailure) -> warn $ namever ++ ": unexpected test success"
@@ -453,3 +500,52 @@ copyBuiltInHaddocks docdir = do
453500 src <- canonicalizePath
454501 (parent (fpFromString ghc) </> "../share/doc/ghc/html/libraries")
455502 copyDir src docdir
503+
504+------------- Previous results
505+
506+-- | The previous actions that can be run
507+data ResultType = Build | Haddock | Test
508+ deriving (Show, Enum, Eq, Ord, Bounded, Read)
509+
510+-- | The result generated on a previous run
511+data PrevResult = PRNoResult | PRSuccess | PRFailure
512+ deriving (Show, Enum, Eq, Ord, Bounded, Read)
513+
514+-- | Check if we should rerun based on a PrevResult and the expected status
515+checkPrevResult :: PrevResult -> TestState -> Bool
516+checkPrevResult _ Don'tBuild = False
517+checkPrevResult PRNoResult _ = True
518+checkPrevResult PRSuccess _ = False
519+checkPrevResult PRFailure ExpectSuccess = True
520+checkPrevResult PRFailure _ = False
521+
522+withPRPath :: PerformBuild -> ResultType -> PackageIdentifier -> (FilePath -> IO a) -> IO a
523+withPRPath pb rt ident inner = do
524+ createTree $ parent fp
525+ inner fp
526+ where
527+ fp = pbPrevResDir pb </> fpFromString (show rt) </> fpFromText (display ident)
528+
529+successBS, failureBS :: ByteString
530+successBS = "success"
531+failureBS = "failure"
532+
533+getPreviousResult :: PerformBuild -> ResultType -> PackageIdentifier -> IO PrevResult
534+getPreviousResult w x y = withPRPath w x y $ \fp -> do
535+ eres <- tryIO $ readFile fp
536+ return $ case eres of
537+ Right bs
538+ | bs == successBS -> PRSuccess
539+ | bs == failureBS -> PRFailure
540+ _ -> PRNoResult
541+
542+savePreviousResult :: PerformBuild -> ResultType -> PackageIdentifier -> Bool -> IO ()
543+savePreviousResult pb rt ident res =
544+ withPRPath pb rt ident $ \fp -> writeFile fp $
545+ if res then successBS else failureBS
546+
547+deletePreviousResults :: PerformBuild -> PackageIdentifier -> IO ()
548+deletePreviousResults pb name =
549+ forM_ [minBound..maxBound] $ \rt ->
550+ withPRPath pb rt name $ \fp ->
551+ void $ tryIO $ removeFile fp