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