Merge branch 'incremental'

Stackage/CompleteBuild.hs

@@ -68,7 +68,7 @@ nightlySettings :: Text -- ^ day
                 -> Settings
 nightlySettings day plan' = Settings
     { planFile = nightlyPlanFile day
-    , buildDir = fpFromText $ "builds/stackage-nightly-" ++ day
+    , buildDir = fpFromText $ "builds/nightly"
     , logDir = fpFromText $ "logs/stackage-nightly-" ++ day
     , title = \ghcVer -> concat
         [ "Stackage Nightly "
@@ -121,7 +121,7 @@ getSettings man (LTS bumpType) = do
 
     return Settings
         { planFile = newfile
-        , buildDir = fpFromText $ "builds/stackage-lts-" ++ tshow new
+        , buildDir = fpFromText $ "builds/lts"
         , logDir = fpFromText $ "logs/stackage-lts-" ++ tshow new
         , title = \ghcVer -> concat
             [ "LTS Haskell "

Stackage/GhcPkg.hs

@@ -0,0 +1,104 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+-- | General commands related to ghc-pkg.
+
+module Stackage.GhcPkg
+    ( setupPackageDatabase
+    ) where
+
+import           Data.Conduit
+import qualified Data.Conduit.List as CL
+import           Data.Conduit.Process
+import qualified Data.Conduit.Text as CT
+import           Data.Maybe
+import           Data.Text (Text)
+import qualified Data.Text as T
+import           Distribution.Compat.ReadP
+import           Distribution.Package
+import           Distribution.Text (parse)
+import           Filesystem.Path.CurrentOS (FilePath)
+import qualified Filesystem.Path.CurrentOS as FP
+import Data.Map (Map)
+import Data.Version (Version)
+import Stackage.Prelude
+import Filesystem (removeTree)
+
+setupPackageDatabase
+    :: Maybe FilePath -- ^ database location, Nothing if using global DB
+    -> 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 onUnregister = do
+    registered1 <- getRegisteredPackages flags
+    forM_ registered1 $ \pi@(PackageIdentifier name version) ->
+        case lookup name toInstall of
+            Just version' | version /= version' -> unregisterPackage log' onUnregister docDir flags pi
+            _ -> return ()
+    broken <- getBrokenPackages flags
+    forM_ broken $ unregisterPackage log' onUnregister docDir flags
+    foldMap (\(PackageIdentifier name _) -> singletonSet name)
+        <$> getRegisteredPackages flags
+  where
+    flags = ghcPkgFlags mdb
+
+ghcPkgFlags :: Maybe FilePath -> [String]
+ghcPkgFlags mdb =
+    "--no-user-package-db" :
+    case mdb of
+        Nothing -> ["--global"]
+        Just fp -> ["--package-db=" ++ fpToString fp]
+
+-- | Get broken packages.
+getBrokenPackages :: [String] -> IO [PackageIdentifier]
+getBrokenPackages flags = do
+    (_,ps) <- sourceProcessWithConsumer
+                  (proc
+                       "ghc-pkg"
+                       ("check" : "--simple-output" : flags))
+                  (CT.decodeUtf8 $= CT.lines $= CL.consume)
+    return (mapMaybe parsePackageIdent (T.words (T.unlines ps)))
+
+-- | Get available packages.
+getRegisteredPackages :: [String] -> IO [PackageIdentifier]
+getRegisteredPackages flags = do
+    (_,ps) <- sourceProcessWithConsumer
+                  (proc
+                       "ghc-pkg"
+                       ("list" : "--simple-output" : flags))
+                  (CT.decodeUtf8 $= CT.lines $= CL.consume)
+    return (mapMaybe parsePackageIdent (T.words (T.unlines ps)))
+
+-- | Parse a package identifier: foo-1.2.3
+parsePackageIdent :: Text -> Maybe PackageIdentifier
+parsePackageIdent = fmap fst .
+    listToMaybe .
+    filter (null . snd) .
+    readP_to_S parse . T.unpack
+
+-- | 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' 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

@@ -19,11 +19,12 @@ import qualified Data.Map                    as Map
 import           Data.NonNull                (fromNullable)
 import           Filesystem                  (canonicalizePath, createTree,
                                               getWorkingDirectory, isDirectory,
-                                              removeTree, rename)
+                                              removeTree, rename, isFile, removeFile)
 import           Filesystem.Path             (parent)
 import qualified Filesystem.Path             as F
 import           Stackage.BuildConstraints
 import           Stackage.BuildPlan
+import           Stackage.GhcPkg
 import           Stackage.PackageDescription
 import           Stackage.Prelude            hiding (pi)
 import           System.Directory            (findExecutable)
@@ -135,6 +136,10 @@ pbLibDir pb = pbInstallDest pb </> "lib"
 pbDataDir pb = pbInstallDest pb </> "share"
 pbDocDir pb = pbInstallDest pb </> "doc"
 
+-- | Directory keeping previous result info
+pbPrevResDir :: PerformBuild -> FilePath
+pbPrevResDir pb = pbInstallDest pb </> "prevres"
+
 performBuild :: PerformBuild -> IO [Text]
 performBuild pb = do
     cwd <- getWorkingDirectory
@@ -162,12 +167,13 @@ performBuild' pb@PerformBuild {..} = withBuildDir $ \builddir -> do
         $ \ClosedStream Inherited Inherited -> return ()
 
     let removeTree' fp = whenM (isDirectory fp) (removeTree fp)
-    mapM_ removeTree' [pbInstallDest, pbLogDir]
+    removeTree' pbLogDir
 
-    forM_ (pbDatabase pb) $ \db -> do
+    forM_ (pbDatabase pb) $ \db ->
-        createTree $ parent db
+        unlessM (isFile $ db </> "package.cache") $ do
-        withCheckedProcess (proc "ghc-pkg" ["init", fpToString db])
+            createTree $ parent db
-            $ \ClosedStream Inherited Inherited -> return ()
+            withCheckedProcess (proc "ghc-pkg" ["init", fpToString db])
+                $ \ClosedStream Inherited Inherited -> return ()
     pbLog $ encodeUtf8 "Copying built-in Haddocks\n"
     copyBuiltInHaddocks (pbDocDir pb)
 
@@ -187,7 +193,15 @@ performBuild' pb@PerformBuild {..} = withBuildDir $ \builddir -> do
     env <- getEnvironment
     haddockFiles <- newTVarIO mempty
 
-    forM_ packageMap $ \pi -> void $ async $ singleBuild pb SingleBuild
+    registeredPackages <- setupPackageDatabase
+        (pbDatabase pb)
+        (pbDocDir pb)
+        pbLog
+        (ppVersion <$> bpPackages pbPlan)
+        (deletePreviousResults pb)
+
+    forM_ packageMap $ \pi -> void $ async $ singleBuild pb registeredPackages
+      SingleBuild
         { sbSem = sem
         , sbErrsVar = errsVar
         , sbWarningsVar = warningsVar
@@ -249,8 +263,10 @@ data SingleBuild = SingleBuild
     , sbHaddockFiles  :: TVar (Map Text FilePath) -- ^ package-version, .haddock file
     }
 
-singleBuild :: PerformBuild -> SingleBuild -> IO ()
+singleBuild :: PerformBuild
-singleBuild pb@PerformBuild {..} SingleBuild {..} =
+            -> Set PackageName -- ^ registered packages
+            -> SingleBuild -> IO ()
+singleBuild pb@PerformBuild {..} registeredPackages SingleBuild {..} =
       withCounter sbActive
     $ handle updateErrs
     $ (`finally` void (atomically $ tryPutTMVar (piResult sbPackageInfo) False))
@@ -262,11 +278,13 @@ singleBuild pb@PerformBuild {..} SingleBuild {..} =
         let wfd comps =
                 waitForDeps sbToolMap sbPackageMap comps pbPlan sbPackageInfo
                 . withTSem sbSem
-        wfd libComps buildLibrary
+        withUnpacked <- wfd libComps buildLibrary
 
-        wfd testComps runTests
+        wfd testComps (runTests withUnpacked)
 
-    name = display $ piName sbPackageInfo
+    pname = piName sbPackageInfo
+    pident = PackageIdentifier pname (ppVersion $ piPlan sbPackageInfo)
+    name = display pname
     namever = concat
         [ name
         , "-"
@@ -335,19 +353,37 @@ singleBuild pb@PerformBuild {..} SingleBuild {..} =
     buildLibrary = wf libOut $ \outH -> do
         let run a b = do when pbVerbose $ log' (unwords (a : b))
                          runChild outH a b
-        log' $ "Unpacking " ++ namever
-        runParent outH "cabal" ["unpack", namever]
 
-        log' $ "Configuring " ++ namever
+        isUnpacked <- newIORef False
-        run "cabal" $ "configure" : configArgs
+        let withUnpacked inner = do
+                unlessM (readIORef isUnpacked) $ do
+                    log' $ "Unpacking " ++ namever
+                    runParent outH "cabal" ["unpack", namever]
+                    writeIORef isUnpacked True
+                inner
 
-        log' $ "Building " ++ namever
+        isConfiged <- newIORef False
-        run "cabal" ["build"]
+        let withConfiged inner = withUnpacked $ do
+                unlessM (readIORef isConfiged) $ do
+                    log' $ "Configuring " ++ namever
+                    run "cabal" $ "configure" : configArgs
+                    writeIORef isConfiged True
+                inner
 
-        log' $ "Copying/registering " ++ namever
+        prevBuildResult <- getPreviousResult pb Build pident
-        run "cabal" ["copy"]
+        unless (prevBuildResult == PRSuccess) $ withConfiged $ do
-        withMVar sbRegisterMutex $ const $
+          assert (pname `notMember` registeredPackages) $ do
-            run "cabal" ["register"]
+            deletePreviousResults pb pident
+
+            log' $ "Building " ++ namever
+            run "cabal" ["build"]
+
+            log' $ "Copying/registering " ++ namever
+            run "cabal" ["copy"]
+            withMVar sbRegisterMutex $ const $
+                run "cabal" ["register"]
+
+            savePreviousResult pb Build pident True
 
         -- Even if the tests later fail, we can allow other libraries to build
         -- on top of our successful results
@@ -357,7 +393,11 @@ singleBuild pb@PerformBuild {..} SingleBuild {..} =
         -- dependency's haddocks before this finishes
         atomically $ putTMVar (piResult sbPackageInfo) True
 
-        when (pbEnableHaddock && pcHaddocks /= Don'tBuild && not (null $ sdModules $ ppDesc $ piPlan sbPackageInfo)) $ do
+        prevHaddockResult <- getPreviousResult pb Haddock pident
+        let needHaddock = pbEnableHaddock
+                       && checkPrevResult prevHaddockResult pcHaddocks
+                       && not (null $ sdModules $ ppDesc $ piPlan sbPackageInfo)
+        when needHaddock $ withConfiged $ do
             log' $ "Haddocks " ++ namever
             hfs <- readTVarIO sbHaddockFiles
             let hfsOpts = flip map (mapToList hfs) $ \(pkgVer, hf) -> concat
@@ -392,15 +432,21 @@ singleBuild pb@PerformBuild {..} SingleBuild {..} =
                                    $ modifyTVar sbHaddockFiles
                                    $ insertMap namever newPath
 
+            savePreviousResult pb Haddock pident $ either (const False) (const True) eres
             case (eres, pcHaddocks) of
                 (Left e, ExpectSuccess) -> throwM e
                 (Right (), ExpectFailure) -> warn $ namever ++ ": unexpected Haddock success"
                 _ -> return ()
 
-    runTests = wf testOut $ \outH -> do
+        return withUnpacked
+
+    runTests withUnpacked = wf testOut $ \outH -> do
         let run = runChild outH
 
-        when (pbEnableTests && pcTests /= Don'tBuild) $ do
+        prevTestResult <- getPreviousResult pb Test pident
+        let needTest = pbEnableTests
+                    && checkPrevResult prevTestResult pcTests
+        when needTest $ withUnpacked $ do
             log' $ "Test configure " ++ namever
             run "cabal" $ "configure" : "--enable-tests" : configArgs
 
@@ -411,6 +457,7 @@ singleBuild pb@PerformBuild {..} SingleBuild {..} =
                 log' $ "Test run " ++ namever
                 run "cabal" ["test", "--log=" ++ fpToText testRunOut]
 
+            savePreviousResult pb Test pident $ either (const False) (const True) eres
             case (eres, pcTests) of
                 (Left e, ExpectSuccess) -> throwM e
                 (Right (), ExpectFailure) -> warn $ namever ++ ": unexpected test success"
@@ -453,3 +500,52 @@ copyBuiltInHaddocks docdir = do
             src <- canonicalizePath
                 (parent (fpFromString ghc) </> "../share/doc/ghc/html/libraries")
             copyDir src docdir
+
+------------- Previous results
+
+-- | The previous actions that can be run
+data ResultType = Build | Haddock | Test
+    deriving (Show, Enum, Eq, Ord, Bounded, Read)
+
+-- | The result generated on a previous run
+data PrevResult = PRNoResult | PRSuccess | PRFailure
+    deriving (Show, Enum, Eq, Ord, Bounded, Read)
+
+-- | Check if we should rerun based on a PrevResult and the expected status
+checkPrevResult :: PrevResult -> TestState -> Bool
+checkPrevResult _          Don'tBuild    = False
+checkPrevResult PRNoResult _             = True
+checkPrevResult PRSuccess  _             = False
+checkPrevResult PRFailure  ExpectSuccess = True
+checkPrevResult PRFailure  _             = False
+
+withPRPath :: PerformBuild -> ResultType -> PackageIdentifier -> (FilePath -> IO a) -> IO a
+withPRPath pb rt ident inner = do
+    createTree $ parent fp
+    inner fp
+  where
+    fp = pbPrevResDir pb </> fpFromString (show rt) </> fpFromText (display ident)
+
+successBS, failureBS :: ByteString
+successBS = "success"
+failureBS = "failure"
+
+getPreviousResult :: PerformBuild -> ResultType -> PackageIdentifier -> IO PrevResult
+getPreviousResult w x y = withPRPath w x y $ \fp -> do
+    eres <- tryIO $ readFile fp
+    return $ case eres of
+        Right bs
+            | bs == successBS -> PRSuccess
+            | bs == failureBS -> PRFailure
+        _                     -> PRNoResult
+
+savePreviousResult :: PerformBuild -> ResultType -> PackageIdentifier -> Bool -> IO ()
+savePreviousResult pb rt ident res =
+    withPRPath pb rt ident $ \fp -> writeFile fp $
+        if res then successBS else failureBS
+
+deletePreviousResults :: PerformBuild -> PackageIdentifier -> IO ()
+deletePreviousResults pb name =
+    forM_ [minBound..maxBound] $ \rt ->
+    withPRPath pb rt name $ \fp ->
+    void $ tryIO $ removeFile fp

stackage.cabal

@@ -23,6 +23,7 @@ library
                        Stackage.BuildPlan
                        Stackage.CheckBuildPlan
                        Stackage.UpdateBuildPlan
+                       Stackage.GhcPkg
                        Stackage.GithubPings
                        Stackage.InstallBuild
                        Stackage.PackageDescription
@@ -63,6 +64,7 @@ library
                      , streaming-commons >= 0.1.7.1
                      , semigroups
                      , xml-conduit
+                     , conduit
 
 executable stackage
   default-language:    Haskell2010