Merge branch 'master' into new-upload

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: "

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 =
+    runIn wdir getOutH cmd args = do
-        withCheckedProcess cp $ \ClosedStream UseProvidedHandle UseProvidedHandle ->
+        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
+        ref <- newIORef Nothing
-        withBinaryFile (fpToString fp) WriteMode inner'
+        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
+    runTests withUnpacked = wf testOut $ \getOutH -> do
-        let run = runChild outH
+        let run = runChild getOutH
 
         prevTestResult <- getPreviousResult pb Test pident
         let needTest = pbEnableTests

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.