Add 'hadrian/' from commit '45f3bff7016a2a0cd9a5455a882ced984655e90b'

git-subtree-dir: hadrian
git-subtree-mainline: 575b35f4cdc18045bccd42d341d6f25d95c0696c
git-subtree-split: 45f3bff7016a2a0cd9a5455a882ced984655e90b

1 files changed, 103 insertions, 0 deletions

diff --git a/hadrian/src/Rules/Register.hs b/hadrian/src/Rules/Register.hs
new file mode 100644
index 0000000000..62023d72e4
--- /dev/null
+++ b/hadrian/src/Rules/Register.hs
@@ -0,0 +1,103 @@
+module Rules.Register (configurePackage, registerPackage) where
+
+import Distribution.ParseUtils
+import Distribution.Version (Version)
+import qualified Distribution.Compat.ReadP   as Parse
+import qualified Hadrian.Haskell.Cabal.Parse as Cabal
+import Hadrian.Expression
+import qualified System.Directory            as IO
+
+import Base
+import Context
+import Packages
+import Settings
+import Target
+import Utilities
+
+parseCabalName :: String -> Maybe (String, Version)
+parseCabalName = readPToMaybe parse
+  where
+    parse = (,) <$> (parsePackageName <* Parse.char '-') <*> parseOptVersion
+
+-- | Configure a package and build its @setup-config@ file.
+configurePackage :: Context -> Rules ()
+configurePackage context@Context {..} = do
+    root <- buildRootRules
+    root -/- contextDir context -/- "setup-config" %> \_ ->
+        Cabal.configurePackage context
+
+-- | Register a package and initialise the corresponding package database if
+-- need be. Note that we only register packages in 'Stage0' and 'Stage1'.
+registerPackage :: [(Resource, Int)] -> Context -> Rules ()
+registerPackage rs context@Context {..} = when (stage < Stage2) $ do
+    root <- buildRootRules
+
+    -- Initialise the package database.
+    root -/- relativePackageDbPath stage -/- packageDbStamp %> \stamp ->
+        writeFileLines stamp []
+
+    -- TODO: Add proper error handling for partial functions.
+    -- Register a package.
+    root -/- relativePackageDbPath stage -/- "*.conf" %> \conf -> do
+        settings <- libPath context <&> (-/- "settings")
+        platformConstants <- libPath context <&> (-/- "platformConstants")
+        need [settings, platformConstants]
+        let Just pkgName | takeBaseName conf == "rts" = Just "rts"
+                         | otherwise = fst <$> parseCabalName (takeBaseName conf)
+        let Just pkg = findPackageByName pkgName
+        isBoot <- (pkg `notElem`) <$> stagePackages Stage0
+        case stage of
+            Stage0 | isBoot -> copyConf  rs (context { package = pkg }) conf
+            _               -> buildConf rs (context { package = pkg }) conf
+
+buildConf :: [(Resource, Int)] -> Context -> FilePath -> Action ()
+buildConf _ context@Context {..} _conf = do
+    depPkgIds <- cabalDependencies context
+
+    -- Calling 'need' on @setupConfig@, triggers the package configuration.
+    setupConfig <- pkgSetupConfigFile context
+    need [setupConfig]
+    need =<< mapM (\pkgId -> packageDbPath stage <&> (-/- pkgId <.> "conf")) depPkgIds
+
+    ways <- interpretInContext context (getLibraryWays <> if package == rts then getRtsWays else mempty)
+    need =<< concatMapM (libraryTargets True) [ context { way = w } | w <- ways ]
+
+    -- We might need some package-db resource to limit read/write, see packageRules.
+    path <- buildPath context
+
+    -- Special package cases (these should ideally be rolled into Cabal).
+    when (package == rts) $
+        -- If Cabal knew about "generated-headers", we could read them from the
+        -- 'configuredCabal' information, and just "need" them here.
+        need [ path -/- "DerivedConstants.h"
+             , path -/- "ghcautoconf.h"
+             , path -/- "ghcplatform.h"
+             , path -/- "ghcversion.h"
+             , path -/- "ffi.h" ]
+
+    when (package == integerGmp) $ need [path -/- "ghc-gmp.h"]
+
+    -- Copy and register the package.
+    Cabal.copyPackage context
+    Cabal.registerPackage context
+
+copyConf :: [(Resource, Int)] -> Context -> FilePath -> Action ()
+copyConf rs context@Context {..} conf = do
+    depPkgIds <- fmap stdOutToPkgIds . askWithResources rs $
+        target context (GhcPkg Dependencies stage) [pkgName package] []
+    need =<< mapM (\pkgId -> packageDbPath stage <&> (-/- pkgId <.> "conf")) depPkgIds
+    -- We should unregister if the file exists since @ghc-pkg@ will complain
+    -- about existing package: https://github.com/snowleopard/hadrian/issues/543.
+    -- Also, we don't always do the unregistration + registration to avoid
+    -- repeated work after a full build.
+    -- We do not track 'doesFileExist' since we are going to create the file if
+    -- it is currently missing. TODO: Is this the right thing to do?
+    -- See https://github.com/snowleopard/hadrian/issues/569.
+    unlessM (liftIO $ IO.doesFileExist conf) $ do
+        buildWithResources rs $
+            target context (GhcPkg Unregister stage) [pkgName package] []
+        buildWithResources rs $
+            target context (GhcPkg Copy stage) [pkgName package] [conf]
+  where
+    stdOutToPkgIds :: String -> [String]
+    stdOutToPkgIds = drop 1 . concatMap words . lines