0bd3eafac74829e2b585e800a966bdc481bdce9a
[ghc.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
14 import Hadrian.Expression
15 import Hadrian.Haskell.Cabal.Parse as Cabal
16
17 parseCabalName :: String -> Maybe (String, Version)
18 parseCabalName = readPToMaybe parse
19 where parse = (,) <$> (parsePackageName <* Parse.char '-') <*> parseOptVersion
20
21 -- | Build rules for registering packages and initialising package databases
22 -- by running the @ghc-pkg@ utility.
23 registerPackages :: [(Resource, Int)] -> Context -> Rules ()
24 registerPackages rs context@Context {..} = do
25 root <- buildRootRules
26 root -/- relativePackageDbPath stage %>
27 buildStamp rs context
28
29 root -/- relativePackageDbPath stage -/- packageDbStamp %> \stamp ->
30 writeFileLines stamp []
31
32 root -/- relativePackageDbPath stage -/- "*.conf" %> \conf -> do
33 settings <- libPath context <&> (-/- "settings")
34 platformConstants <- libPath context <&> (-/- "platformConstants")
35 need [settings, platformConstants]
36 let Just pkgName | takeBaseName conf == "rts" = Just "rts"
37 | otherwise = fst <$> parseCabalName (takeBaseName conf)
38 let Just pkg = findPackageByName pkgName
39 bootLibs <- filter isLibrary <$> stagePackages Stage0
40 case stage of
41 Stage0 | pkg `notElem` bootLibs -> copyConf rs (context { package = pkg }) conf
42 _ -> buildConf rs (context { package = pkg }) conf
43
44 buildConf :: [(Resource, Int)] -> Context -> FilePath -> Action ()
45 buildConf _ context@Context {..} _conf = do
46 depPkgIds <- cabalDependencies context
47
48 -- setup-config, triggers `ghc-cabal configure`
49 -- everything of a package should depend on that
50 -- in the first place.
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 -- might need some package-db resource to limit read/write,
59 -- see packageRules
60 bldPath <- buildPath context
61
62 -- special package cases (these should ideally be rolled into cabal one way or the other)
63 when (package == rts) $
64 -- iif cabal new about "generated-headers", we could read them from the configuredCabal
65 -- information, and just "need" them here.
66 need [ bldPath -/- "DerivedConstants.h"
67 , bldPath -/- "ghcautoconf.h"
68 , bldPath -/- "ghcplatform.h"
69 , bldPath -/- "ghcversion.h"
70 , bldPath -/- "ffi.h"
71 ]
72
73 when (package == integerGmp) $
74 need [bldPath -/- "ghc-gmp.h"]
75
76 -- copy and register the package
77 copyPackage context
78 registerPackage context
79
80 copyConf :: [(Resource, Int)] -> Context -> FilePath -> Action ()
81 copyConf rs context@Context {..} conf = do
82 depPkgIds <- fmap stdOutToPkgIds . askWithResources rs $
83 target context (GhcPkg Dependencies stage) [pkgName package] []
84 need =<< mapM (\pkgId -> packageDbPath stage <&> (-/- pkgId <.> "conf")) depPkgIds
85 -- we should unregister if the file exists since ghc-pkg will complain
86 -- about existing pkg id (See https://github.com/snowleopard/hadrian/issues/543)
87 -- also, we don't always do the unregistration + registration to avoid
88 -- repeated work after a full build
89 unlessM (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
95 where
96 stdOutToPkgIds :: String -> [String]
97 stdOutToPkgIds = drop 1 . concatMap words . lines
98
99 buildStamp :: [(Resource, Int)] -> Context -> FilePath -> Action ()
100 buildStamp rs Context {..} path = do
101 buildWithResources rs $
102 target (vanillaContext stage ghc) (GhcPkg Init stage) [] [path]
103 putSuccess $ "| Successfully initialised " ++ path