@@ -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)
@@ -134,6 +135,10 @@ pbLibDir pb = pbInstallDest pb </> "lib"
134135pbDataDir pb = pbInstallDest pb </> "share"
135136pbDocDir pb = pbInstallDest pb </> "doc"
136137
138+-- | Directory keeping previous result info
139+pbPrevResDir :: PerformBuild -> FilePath
140+pbPrevResDir pb = pbInstallDest pb </> "prevres"
141+
137142performBuild :: PerformBuild -> IO [Text]
138143performBuild pb = do
139144 cwd <- getWorkingDirectory
@@ -161,12 +166,13 @@ performBuild' pb@PerformBuild {..} = withBuildDir $ \builddir -> do
161166 $ \ClosedStream Inherited Inherited -> return ()
162167
163168 let removeTree' fp = whenM (isDirectory fp) (removeTree fp)
164− mapM_ removeTree' [pbInstallDest, pbLogDir]
169+ removeTree' pbLogDir
165170
166− forM_ (pbDatabase pb) $ \db -> do
167− createTree $ parent db
168− withCheckedProcess (proc "ghc-pkg" ["init", fpToString db])
169− $ \ClosedStream Inherited Inherited -> return ()
171+ forM_ (pbDatabase pb) $ \db ->
172+ unlessM (isFile $ db </> "package.cache") $ do
173+ createTree $ parent db
174+ withCheckedProcess (proc "ghc-pkg" ["init", fpToString db])
175+ $ \ClosedStream Inherited Inherited -> return ()
170176 pbLog $ encodeUtf8 "Copying built-in Haddocks\n"
171177 copyBuiltInHaddocks (pbDocDir pb)
172178
@@ -186,7 +192,12 @@ performBuild' pb@PerformBuild {..} = withBuildDir $ \builddir -> do
186192 env <- getEnvironment
187193 haddockFiles <- newTVarIO mempty
188194
189− forM_ packageMap $ \pi -> void $ async $ singleBuild pb SingleBuild
195+ registeredPackages <- setupPackageDatabase
196+ (pbDatabase pb)
197+ (ppVersion <$> bpPackages pbPlan)
198+
199+ forM_ packageMap $ \pi -> void $ async $ singleBuild pb registeredPackages
200+ SingleBuild
190201 { sbSem = sem
191202 , sbErrsVar = errsVar
192203 , sbWarningsVar = warningsVar
@@ -248,8 +259,10 @@ data SingleBuild = SingleBuild
248259 , sbHaddockFiles :: TVar (Map Text FilePath) -- ^ package-version, .haddock file
249260 }
250261
251−singleBuild :: PerformBuild -> SingleBuild -> IO ()
252−singleBuild pb@PerformBuild {..} SingleBuild {..} =
262+singleBuild :: PerformBuild
263+ -> Set PackageName -- ^ registered packages
264+ -> SingleBuild -> IO ()
265+singleBuild pb@PerformBuild {..} registeredPackages SingleBuild {..} =
253266 withCounter sbActive
254267 $ handle updateErrs
255268 $ (`finally` void (atomically $ tryPutTMVar (piResult sbPackageInfo) False))
@@ -261,11 +274,12 @@ singleBuild pb@PerformBuild {..} SingleBuild {..} =
261274 let wfd comps =
262275 waitForDeps sbToolMap sbPackageMap comps pbPlan sbPackageInfo
263276 . withTSem sbSem
264− wfd libComps buildLibrary
277+ withUnpacked <- wfd libComps buildLibrary
265278
266− wfd testComps runTests
279+ wfd testComps (runTests withUnpacked)
267280
268− name = display $ piName sbPackageInfo
281+ pname = piName sbPackageInfo
282+ name = display pname
269283 namever = concat
270284 [ name
271285 , "-"
@@ -333,19 +347,34 @@ singleBuild pb@PerformBuild {..} SingleBuild {..} =
333347 buildLibrary = wf libOut $ \outH -> do
334348 let run a b = do when pbVerbose $ log' (unwords (a : b))
335349 runChild outH a b
336− log' $ "Unpacking " ++ namever
337− runParent outH "cabal" ["unpack", namever]
338−
339− log' $ "Configuring " ++ namever
340− run "cabal" $ "configure" : configArgs
341350
342− log' $ "Building " ++ namever
343− run "cabal" ["build"]
344−
345− log' $ "Copying/registering " ++ namever
346− run "cabal" ["copy"]
347− withMVar sbRegisterMutex $ const $
348− run "cabal" ["register"]
351+ isUnpacked <- newIORef False
352+ let withUnpacked inner = do
353+ unlessM (readIORef isUnpacked) $ do
354+ log' $ "Unpacking " ++ namever
355+ runParent outH "cabal" ["unpack", namever]
356+ writeIORef isUnpacked True
357+ inner
358+
359+ isConfiged <- newIORef False
360+ let withConfiged inner = withUnpacked $ do
361+ unlessM (readIORef isConfiged) $ do
362+ log' $ "Configuring " ++ namever
363+ run "cabal" $ "configure" : configArgs
364+ writeIORef isConfiged True
365+ inner
366+
367+ unless (pname `member` registeredPackages) $ withConfiged $ do
368+ deletePreviousResults pb pname
369+ -- FIXME delete old Haddocks?
370+
371+ log' $ "Building " ++ namever
372+ run "cabal" ["build"]
373+
374+ log' $ "Copying/registering " ++ namever
375+ run "cabal" ["copy"]
376+ withMVar sbRegisterMutex $ const $
377+ run "cabal" ["register"]
349378
350379 -- Even if the tests later fail, we can allow other libraries to build
351380 -- on top of our successful results
@@ -355,7 +384,11 @@ singleBuild pb@PerformBuild {..} SingleBuild {..} =
355384 -- dependency's haddocks before this finishes
356385 atomically $ putTMVar (piResult sbPackageInfo) True
357386
358− when (pbEnableHaddock && pcHaddocks /= Don'tBuild && not (null $ sdModules $ ppDesc $ piPlan sbPackageInfo)) $ do
387+ prevHaddockResult <- getPreviousResult pb Haddock pname
388+ let needHaddock = pbEnableHaddock
389+ && checkPrevResult prevHaddockResult pcHaddocks
390+ && not (null $ sdModules $ ppDesc $ piPlan sbPackageInfo)
391+ when needHaddock $ withConfiged $ do
359392 log' $ "Haddocks " ++ namever
360393 hfs <- readTVarIO sbHaddockFiles
361394 let hfsOpts = flip map (mapToList hfs) $ \(pkgVer, hf) -> concat
@@ -390,15 +423,21 @@ singleBuild pb@PerformBuild {..} SingleBuild {..} =
390423 $ modifyTVar sbHaddockFiles
391424 $ insertMap namever newPath
392425
426+ savePreviousResult pb Haddock pname $ either (const False) (const True) eres
393427 case (eres, pcHaddocks) of
394428 (Left e, ExpectSuccess) -> throwM e
395429 (Right (), ExpectFailure) -> warn $ namever ++ ": unexpected Haddock success"
396430 _ -> return ()
397431
398− runTests = wf testOut $ \outH -> do
432+ return withUnpacked
433+
434+ runTests withUnpacked = wf testOut $ \outH -> do
399435 let run = runChild outH
400436
401− when (pbEnableTests && pcTests /= Don'tBuild) $ do
437+ prevTestResult <- getPreviousResult pb Test pname
438+ let needTest = pbEnableTests
439+ && checkPrevResult prevTestResult pcTests
440+ when needTest $ withUnpacked $ do
402441 log' $ "Test configure " ++ namever
403442 run "cabal" $ "configure" : "--enable-tests" : configArgs
404443
@@ -409,6 +448,7 @@ singleBuild pb@PerformBuild {..} SingleBuild {..} =
409448 log' $ "Test run " ++ namever
410449 run "cabal" ["test", "--log=" ++ fpToText testRunOut]
411450
451+ savePreviousResult pb Test pname $ either (const False) (const True) eres
412452 case (eres, pcTests) of
413453 (Left e, ExpectSuccess) -> throwM e
414454 (Right (), ExpectFailure) -> warn $ namever ++ ": unexpected test success"
@@ -451,3 +491,50 @@ copyBuiltInHaddocks docdir = do
451491 src <- canonicalizePath
452492 (parent (fpFromString ghc) </> "../share/doc/ghc/html/libraries")
453493 copyDir src docdir
494+
495+------------- Previous results
496+
497+-- | The previous actions that can be run
498+data ResultType = Haddock | Test
499+ deriving (Show, Enum, Eq, Ord, Bounded, Read)
500+
501+-- | The result generated on a previous run
502+data PrevResult = PRNoResult | PRSuccess | PRFailure
503+
504+-- | Check if we should rerun based on a PrevResult and the expected status
505+checkPrevResult _ Don'tBuild = False
506+checkPrevResult PRNoResult _ = True
507+checkPrevResult PRSuccess _ = False
508+checkPrevResult PRFailure ExpectSuccess = True
509+checkPrevResult PRFailure _ = False
510+
511+withPRPath :: PerformBuild -> ResultType -> PackageName -> (FilePath -> IO a) -> IO a
512+withPRPath pb rt (PackageName name) inner = do
513+ createTree $ parent fp
514+ inner fp
515+ where
516+ fp = pbPrevResDir pb </> fpFromString (show rt) </> fpFromString name
517+
518+successBS, failureBS :: ByteString
519+successBS = "success"
520+failureBS = "failure"
521+
522+getPreviousResult :: PerformBuild -> ResultType -> PackageName -> IO PrevResult
523+getPreviousResult w x y = withPRPath w x y $ \fp -> do
524+ eres <- tryIO $ readFile fp
525+ return $ case eres of
526+ Right bs
527+ | bs == successBS -> PRSuccess
528+ | bs == failureBS -> PRFailure
529+ _ -> PRNoResult
530+
531+savePreviousResult :: PerformBuild -> ResultType -> PackageName -> Bool -> IO ()
532+savePreviousResult pb rt name res =
533+ withPRPath pb rt name $ \fp -> writeFile fp $
534+ if res then successBS else failureBS
535+
536+deletePreviousResults :: PerformBuild -> PackageName -> IO ()
537+deletePreviousResults pb name =
538+ forM_ [minBound..maxBound] $ \rt ->
539+ withPRPath pb rt name $ \fp ->
540+ void $ tryIO $ removeFile fp