hadrian: eliminate most of the remaining big rule enumerations
[ghc.git] / hadrian / src / Rules / Register.hs
1 module Rules.Register (configurePackageRules, registerPackageRules) where
2
3 import Base
4 import Context
5 import Hadrian.BuildPath
6 import Hadrian.Expression
7 import Packages
8 import Settings
9 import Settings.Default
10 import Target
11 import Utilities
12
13 import Distribution.ParseUtils
14 import Distribution.Version (Version)
15
16 import qualified Distribution.Compat.ReadP as Parse
17 import qualified Hadrian.Haskell.Cabal.Parse as Cabal
18 import qualified System.Directory as IO
19 import qualified Text.Parsec as Parsec
20
21 -- * Configuring
22
23 -- | Configure a package and build its @setup-config@ file.
24 configurePackageRules :: Rules ()
25 configurePackageRules = do
26 root <- buildRootRules
27 root -/- "**/setup-config" %> \path ->
28 parsePath (parseSetupConfig root) "<setup config path parser>" path
29 >>= configurePackage
30
31 parseSetupConfig :: FilePath -> Parsec.Parsec String () (Stage, FilePath)
32 parseSetupConfig root = do
33 _ <- Parsec.string root *> Parsec.optional (Parsec.char '/')
34 stage <- parseStage
35 _ <- Parsec.char '/'
36 pkgPath <- Parsec.manyTill Parsec.anyChar
37 (Parsec.try $ Parsec.string "/setup-config")
38 return (stage, pkgPath)
39
40 configurePackage :: (Stage, FilePath) -> Action ()
41 configurePackage (stage, pkgpath) = do
42 pkg <- getPackageByPath pkgpath
43 Cabal.configurePackage (Context stage pkg vanilla)
44
45 -- * Registering
46
47 -- | Register a package and initialise the corresponding package database if
48 -- need be. Note that we only register packages in 'Stage0' and 'Stage1'.
49 registerPackageRules :: [(Resource, Int)] -> Stage -> Rules ()
50 registerPackageRules rs stage = do
51 root <- buildRootRules
52
53 -- Initialise the package database.
54 root -/- relativePackageDbPath stage -/- packageDbStamp %> \stamp ->
55 writeFileLines stamp []
56
57 -- Register a package.
58 root -/- relativePackageDbPath stage -/- "*.conf" %> \conf -> do
59 let libpath = takeDirectory (takeDirectory conf)
60 settings = libpath -/- "settings"
61 platformConstants = libpath -/- "platformConstants"
62
63 need [settings, platformConstants]
64
65 pkgName <- getPackageNameFromConfFile conf
66 pkg <- getPackageByName pkgName
67 isBoot <- (pkg `notElem`) <$> stagePackages Stage0
68
69 let ctx = Context stage pkg vanilla
70 case stage of
71 Stage0 | isBoot -> copyConf rs ctx conf
72 _ -> buildConf rs ctx conf
73
74 buildConf :: [(Resource, Int)] -> Context -> FilePath -> Action ()
75 buildConf _ context@Context {..} _conf = do
76 depPkgIds <- cabalDependencies context
77
78 -- Calling 'need' on @setupConfig@, triggers the package configuration.
79 setupConfig <- pkgSetupConfigFile context
80 need [setupConfig]
81 need =<< mapM (\pkgId -> packageDbPath stage <&> (-/- pkgId <.> "conf")) depPkgIds
82
83 ways <- interpretInContext context (getLibraryWays <> if package == rts then getRtsWays else mempty)
84 need =<< concatMapM (libraryTargets True) [ context { way = w } | w <- ways ]
85
86 -- We might need some package-db resource to limit read/write, see packageRules.
87 path <- buildPath context
88
89 -- Special package cases (these should ideally be rolled into Cabal).
90 when (package == rts) $
91 -- If Cabal knew about "generated-headers", we could read them from the
92 -- 'configuredCabal' information, and just "need" them here.
93 need [ path -/- "DerivedConstants.h"
94 , path -/- "ghcautoconf.h"
95 , path -/- "ghcplatform.h"
96 , path -/- "ghcversion.h"
97 , path -/- "ffi.h" ]
98
99 when (package == integerGmp) $ need [path -/- "ghc-gmp.h"]
100
101 -- Copy and register the package.
102 Cabal.copyPackage context
103 Cabal.registerPackage context
104
105 copyConf :: [(Resource, Int)] -> Context -> FilePath -> Action ()
106 copyConf rs context@Context {..} conf = do
107 depPkgIds <- fmap stdOutToPkgIds . askWithResources rs $
108 target context (GhcPkg Dependencies stage) [pkgName package] []
109 need =<< mapM (\pkgId -> packageDbPath stage <&> (-/- pkgId <.> "conf")) depPkgIds
110 -- We should unregister if the file exists since @ghc-pkg@ will complain
111 -- about existing package: https://github.com/snowleopard/hadrian/issues/543.
112 -- Also, we don't always do the unregistration + registration to avoid
113 -- repeated work after a full build.
114 -- We do not track 'doesFileExist' since we are going to create the file if
115 -- it is currently missing. TODO: Is this the right thing to do?
116 -- See https://github.com/snowleopard/hadrian/issues/569.
117 unlessM (liftIO $ IO.doesFileExist conf) $ do
118 buildWithResources rs $
119 target context (GhcPkg Unregister stage) [pkgName package] []
120 buildWithResources rs $
121 target context (GhcPkg Copy stage) [pkgName package] [conf]
122 where
123 stdOutToPkgIds :: String -> [String]
124 stdOutToPkgIds = drop 1 . concatMap words . lines
125
126 getPackageNameFromConfFile :: FilePath -> Action String
127 getPackageNameFromConfFile conf
128 | takeBaseName conf == "rts" = return "rts"
129 | otherwise = case parseCabalName (takeBaseName conf) of
130 Nothing -> error $ "getPackageNameFromConfFile: couldn't parse " ++ conf
131 Just (name, _) -> return name
132
133 parseCabalName :: String -> Maybe (String, Version)
134 parseCabalName = readPToMaybe parse
135 where
136 parse = (,) <$> (parsePackageName <* Parse.char '-') <*> parseOptVersion
137
138 getPackageByName :: String -> Action Package
139 getPackageByName n = case findPackageByName n of
140 Nothing -> error $ "getPackageByName: couldn't find " ++ n
141 Just p -> return p