Refactor package-specific settings (#622)
[hadrian.git] / src / Rules / Register.hs
1 module Rules.Register (configurePackage, registerPackage) where
2
3 import Distribution.ParseUtils
4 import Distribution.Version (Version)
5
6 import Base
7 import Context
8 import GHC
9 import Settings
10 import Target
11 import Utilities
12
13 import Hadrian.Expression
14
15 import qualified Distribution.Compat.ReadP as Parse
16 import qualified System.Directory as IO
17 import qualified Hadrian.Haskell.Cabal.Parse as Cabal
18
19 parseCabalName :: String -> Maybe (String, Version)
20 parseCabalName = readPToMaybe parse
21 where
22 parse = (,) <$> (parsePackageName <* Parse.char '-') <*> parseOptVersion
23
24 -- | Configure a package and build its @setup-config@ file.
25 configurePackage :: Context -> Rules ()
26 configurePackage context@Context {..} = do
27 root <- buildRootRules
28 root -/- contextDir context -/- "setup-config" %> \_ ->
29 Cabal.configurePackage context
30
31 -- | Registering a package and initialise the corresponding package database if
32 -- need be.
33 registerPackage :: [(Resource, Int)] -> Context -> Rules ()
34 registerPackage rs context@Context {..} = do
35 root <- buildRootRules
36
37 -- Initialise the package database.
38 root -/- relativePackageDbPath stage -/- packageDbStamp %> \stamp ->
39 writeFileLines stamp []
40
41 -- TODO: Add proper error handling for partial functions.
42 -- Register a package.
43 root -/- relativePackageDbPath stage -/- "*.conf" %> \conf -> do
44 settings <- libPath context <&> (-/- "settings")
45 platformConstants <- libPath context <&> (-/- "platformConstants")
46 need [settings, platformConstants]
47 let Just pkgName | takeBaseName conf == "rts" = Just "rts"
48 | otherwise = fst <$> parseCabalName (takeBaseName conf)
49 let Just pkg = findPackageByName pkgName
50 isBoot <- (pkg `notElem`) <$> stagePackages Stage0
51 case stage of
52 Stage0 | isBoot -> copyConf rs (context { package = pkg }) conf
53 _ -> buildConf rs (context { package = pkg }) conf
54
55 buildConf :: [(Resource, Int)] -> Context -> FilePath -> Action ()
56 buildConf _ context@Context {..} _conf = do
57 depPkgIds <- cabalDependencies context
58
59 -- Calling 'need' on @setupConfig@, triggers the package configuration.
60 setupConfig <- pkgSetupConfigFile context
61 need [setupConfig]
62 need =<< mapM (\pkgId -> packageDbPath stage <&> (-/- pkgId <.> "conf")) depPkgIds
63
64 ways <- interpretInContext context (getLibraryWays <> if package == rts then getRtsWays else mempty)
65 need =<< concatMapM (libraryTargets True) [ context { way = w } | w <- ways ]
66
67 -- We might need some package-db resource to limit read/write, see packageRules.
68 path <- buildPath context
69
70 -- Special package cases (these should ideally be rolled into Cabal).
71 when (package == rts) $
72 -- If Cabal knew about "generated-headers", we could read them from the
73 -- 'configuredCabal' information, and just "need" them here.
74 need [ path -/- "DerivedConstants.h"
75 , path -/- "ghcautoconf.h"
76 , path -/- "ghcplatform.h"
77 , path -/- "ghcversion.h"
78 , path -/- "ffi.h" ]
79
80 when (package == integerGmp) $ need [path -/- "ghc-gmp.h"]
81
82 -- Copy and register the package.
83 Cabal.copyPackage context
84 Cabal.registerPackage context
85
86 copyConf :: [(Resource, Int)] -> Context -> FilePath -> Action ()
87 copyConf rs context@Context {..} conf = do
88 depPkgIds <- fmap stdOutToPkgIds . askWithResources rs $
89 target context (GhcPkg Dependencies stage) [pkgName package] []
90 need =<< mapM (\pkgId -> packageDbPath stage <&> (-/- pkgId <.> "conf")) depPkgIds
91 -- We should unregister if the file exists since @ghc-pkg@ will complain
92 -- about existing package: https://github.com/snowleopard/hadrian/issues/543.
93 -- Also, we don't always do the unregistration + registration to avoid
94 -- repeated work after a full build.
95 -- We do not track 'doesFileExist' since we are going to create the file if
96 -- it is currently missing. TODO: Is this the right thing to do?
97 -- See https://github.com/snowleopard/hadrian/issues/569.
98 unlessM (liftIO $ IO.doesFileExist conf) $ do
99 buildWithResources rs $
100 target context (GhcPkg Unregister stage) [pkgName package] []
101 buildWithResources rs $
102 target context (GhcPkg Clone stage) [pkgName package] [conf]
103 where
104 stdOutToPkgIds :: String -> [String]
105 stdOutToPkgIds = drop 1 . concatMap words . lines