diff --git a/Stackage/GhcPkg.hs b/Stackage/GhcPkg.hs index 1e5171d8..27b7f9e1 100644 --- a/Stackage/GhcPkg.hs +++ b/Stackage/GhcPkg.hs @@ -28,15 +28,16 @@ setupPackageDatabase -> FilePath -- ^ documentation root -> (ByteString -> IO ()) -- ^ logging -> Map PackageName Version -- ^ packages and versions to be installed + -> (PackageIdentifier -> IO ()) -- ^ callback to be used when unregistering a package -> IO (Set PackageName) -- ^ packages remaining in the database after cleanup -setupPackageDatabase mdb docDir log' toInstall = do +setupPackageDatabase mdb docDir log' toInstall onUnregister = do registered1 <- getRegisteredPackages flags forM_ registered1 $ \pi@(PackageIdentifier name version) -> case lookup name toInstall of - Just version' | version /= version' -> unregisterPackage log' docDir flags pi + Just version' | version /= version' -> unregisterPackage log' onUnregister docDir flags pi _ -> return () broken <- getBrokenPackages flags - forM_ broken $ unregisterPackage log' docDir flags + forM_ broken $ unregisterPackage log' onUnregister docDir flags foldMap (\(PackageIdentifier name _) -> singletonSet name) <$> getRegisteredPackages flags where @@ -78,13 +79,26 @@ parsePackageIdent = fmap fst . -- | Unregister a package. unregisterPackage :: (ByteString -> IO ()) -- ^ log func + -> (PackageIdentifier -> IO ()) -- ^ callback to be used when unregistering a package -> FilePath -- ^ doc directory -> [String] -> PackageIdentifier -> IO () -unregisterPackage log' docDir flags ident@(PackageIdentifier name _) = do +unregisterPackage log' onUnregister docDir flags ident@(PackageIdentifier name _) = do log' $ "Unregistering " ++ encodeUtf8 (display ident) ++ "\n" + onUnregister ident + + -- Delete libraries + sourceProcessWithConsumer + (proc "ghc-pkg" ("describe" : flags ++ [unpack $ display ident])) + (CT.decodeUtf8 + $= CT.lines + $= CL.mapMaybe parseLibraryDir + $= CL.mapM_ (void . tryIO . removeTree)) + void (readProcessWithExitCode "ghc-pkg" ("unregister": flags ++ ["--force", unpack $ display name]) "") void $ tryIO $ removeTree $ docDir fpFromText (display ident) + where + parseLibraryDir = fmap fpFromText . stripPrefix "library-dirs: " diff --git a/Stackage/PerformBuild.hs b/Stackage/PerformBuild.hs index db9d78d6..9ed578b9 100644 --- a/Stackage/PerformBuild.hs +++ b/Stackage/PerformBuild.hs @@ -30,7 +30,7 @@ import Stackage.Prelude hiding (pi) import System.Directory (findExecutable) import System.Environment (getEnvironment) import System.IO (IOMode (WriteMode), - withBinaryFile) + openBinaryFile) import System.IO.Temp (withSystemTempDirectory) data BuildException = BuildException (Map PackageName BuildFailure) [Text] @@ -198,6 +198,7 @@ performBuild' pb@PerformBuild {..} = withBuildDir $ \builddir -> do (pbDocDir pb) pbLog (ppVersion <$> bpPackages pbPlan) + (deletePreviousResults pb) forM_ packageMap $ \pi -> void $ async $ singleBuild pb registeredPackages SingleBuild @@ -290,11 +291,12 @@ singleBuild pb@PerformBuild {..} registeredPackages SingleBuild {..} = , display $ ppVersion $ piPlan sbPackageInfo ] - runIn wdir outH cmd args = - withCheckedProcess cp $ \ClosedStream UseProvidedHandle UseProvidedHandle -> + runIn wdir getOutH cmd args = do + outH <- getOutH + withCheckedProcess (cp outH) $ \ClosedStream UseProvidedHandle UseProvidedHandle -> (return () :: IO ()) where - cp = (proc (unpack $ asText cmd) (map (unpack . asText) args)) + cp outH = (proc (unpack $ asText cmd) (map (unpack . asText) args)) { cwd = Just $ fpToString wdir , std_out = UseHandle outH , std_err = UseHandle outH @@ -320,8 +322,21 @@ singleBuild pb@PerformBuild {..} registeredPackages SingleBuild {..} = testRunOut = pbLogDir fpFromText namever "test-run.out" wf fp inner' = do - createTree $ parent fp - withBinaryFile (fpToString fp) WriteMode inner' + ref <- newIORef Nothing + let cleanup = do + mh <- readIORef ref + forM_ mh hClose + getH = do + mh <- readIORef ref + case mh of + Just h -> return h + Nothing -> mask_ $ do + createTree $ parent fp + h <- openBinaryFile (fpToString fp) WriteMode + writeIORef ref $ Just h + return h + + inner' getH `finally` cleanup configArgs = ($ []) $ execWriter $ do when pbAllowNewer $ tell' "--allow-newer" @@ -349,15 +364,15 @@ singleBuild pb@PerformBuild {..} registeredPackages SingleBuild {..} = PackageConstraints {..} = ppConstraints $ piPlan sbPackageInfo - buildLibrary = wf libOut $ \outH -> do + buildLibrary = wf libOut $ \getOutH -> do let run a b = do when pbVerbose $ log' (unwords (a : b)) - runChild outH a b + runChild getOutH a b isUnpacked <- newIORef False let withUnpacked inner = do unlessM (readIORef isUnpacked) $ do log' $ "Unpacking " ++ namever - runParent outH "cabal" ["unpack", namever] + runParent getOutH "cabal" ["unpack", namever] writeIORef isUnpacked True inner @@ -439,8 +454,8 @@ singleBuild pb@PerformBuild {..} registeredPackages SingleBuild {..} = return withUnpacked - runTests withUnpacked = wf testOut $ \outH -> do - let run = runChild outH + runTests withUnpacked = wf testOut $ \getOutH -> do + let run = runChild getOutH prevTestResult <- getPreviousResult pb Test pident let needTest = pbEnableTests diff --git a/build-constraints.yaml b/build-constraints.yaml index 1b343254..4036dc18 100644 --- a/build-constraints.yaml +++ b/build-constraints.yaml @@ -1086,6 +1086,10 @@ expected-haddock-failures: # https://github.com/wereHamster/rethinkdb-client-driver/issues/1 - rethinkdb-client-driver + # Requires build before haddock, which doesn't always happen in incremental + # builds. Could consider special-casing this requirement. + - gtk + # Benchmarks which should not be built. Note that Stackage does *not* generally # build benchmarks. The difference here will be whether dependencies for these # benchmarks are included or not.