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