Refactor Libffi and RTS rules
[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 Hadrian.Haskell.Cabal
8 import Oracles.Setting
9 import Packages
10 import Rules.Gmp
11 import Rules.Rts
12 import Settings
13 import Target
14 import Utilities
15 import Rules.Library
16
17 import Distribution.Version (Version)
18 import qualified Distribution.Parsec as Cabal
19 import qualified Distribution.Types.PackageName as Cabal
20 import qualified Distribution.Types.PackageId as Cabal
21
22 import qualified Hadrian.Haskell.Cabal.Parse as Cabal
23 import qualified System.Directory as IO
24 import qualified Text.Parsec as Parsec
25
26 -- * Configuring
27
28 -- | Configure a package and build its @setup-config@ file, as well as files in
29 -- the @build/pkgName/build/autogen@ directory.
30 configurePackageRules :: Rules ()
31 configurePackageRules = do
32 root <- buildRootRules
33 root -/- "**/setup-config" %> \out -> do
34 (stage, path) <- parsePath (parseSetupConfig root) "<setup config path parser>" out
35 let pkg = unsafeFindPackageByPath path
36 Cabal.configurePackage (Context stage pkg vanilla)
37
38 root -/- "**/autogen/cabal_macros.h" %> \out -> do
39 (stage, path) <- parsePath (parseToBuildSubdirectory root) "<cabal macros path parser>" out
40 let pkg = unsafeFindPackageByPath path
41 Cabal.buildAutogenFiles (Context stage pkg vanilla)
42
43 root -/- "**/autogen/Paths_*.hs" %> \out ->
44 need [takeDirectory out -/- "cabal_macros.h"]
45
46 parseSetupConfig :: FilePath -> Parsec.Parsec String () (Stage, FilePath)
47 parseSetupConfig root = do
48 _ <- Parsec.string root *> Parsec.optional (Parsec.char '/')
49 stage <- parseStage
50 _ <- Parsec.char '/'
51 pkgPath <- Parsec.manyTill Parsec.anyChar
52 (Parsec.try $ Parsec.string "/setup-config")
53 return (stage, pkgPath)
54
55 parseToBuildSubdirectory :: FilePath -> Parsec.Parsec String () (Stage, FilePath)
56 parseToBuildSubdirectory root = do
57 _ <- Parsec.string root *> Parsec.optional (Parsec.char '/')
58 stage <- parseStage
59 _ <- Parsec.char '/'
60 pkgPath <- Parsec.manyTill Parsec.anyChar
61 (Parsec.try $ Parsec.string "/build/")
62 return (stage, pkgPath)
63
64 -- * Registering
65
66 -- | Register a package and initialise the corresponding package database if
67 -- need be. Note that we only register packages in 'Stage0' and 'Stage1'.
68 registerPackageRules :: [(Resource, Int)] -> Stage -> Rules ()
69 registerPackageRules rs stage = do
70 root <- buildRootRules
71
72 -- Initialise the package database.
73 root -/- relativePackageDbPath stage -/- packageDbStamp %> \stamp ->
74 writeFileLines stamp []
75
76 -- Register a package.
77 root -/- relativePackageDbPath stage -/- "*.conf" %> \conf -> do
78 historyDisable
79 let libpath = takeDirectory (takeDirectory conf)
80 settings = libpath -/- "settings"
81 platformConstants = libpath -/- "platformConstants"
82
83 need [settings, platformConstants]
84
85 pkgName <- getPackageNameFromConfFile conf
86 let pkg = unsafeFindPackageByName pkgName
87 isBoot <- (pkg `notElem`) <$> stagePackages Stage0
88
89 let ctx = Context stage pkg vanilla
90 case stage of
91 Stage0 | isBoot -> copyConf rs ctx conf
92 _ -> buildConf rs ctx conf
93
94 buildConf :: [(Resource, Int)] -> Context -> FilePath -> Action ()
95 buildConf _ context@Context {..} conf = do
96 depPkgIds <- cabalDependencies context
97 ensureConfigured context
98 need =<< mapM (\pkgId -> packageDbPath stage <&> (-/- pkgId <.> "conf")) depPkgIds
99
100 ways <- interpretInContext context (getLibraryWays <> if package == rts then getRtsWays else mempty)
101 need =<< concatMapM (libraryTargets True) [ context { way = w } | w <- ways ]
102
103 -- We might need some package-db resource to limit read/write, see packageRules.
104 path <- buildPath context
105
106 -- Special package cases (these should ideally be rolled into Cabal).
107 when (package == rts) $
108 -- If Cabal knew about "generated-headers", we could read them from the
109 -- 'configuredCabal' information, and just "need" them here.
110 need [ path -/- "DerivedConstants.h"
111 , path -/- "ghcautoconf.h"
112 , path -/- "ghcplatform.h"
113 , path -/- "ghcversion.h" ]
114
115 when (package == integerGmp) $ need [path -/- gmpLibraryH]
116
117 -- Copy and register the package.
118 Cabal.copyPackage context
119 Cabal.registerPackage context
120
121 -- | Dynamic RTS library files need symlinks (Rules.Rts.rtsRules).
122 when (package == rts) (needRtsSymLinks stage ways)
123
124 -- The above two steps produce an entry in the package database, with copies
125 -- of many of the files we have build, e.g. Haskell interface files. We need
126 -- to record this side effect so that Shake can cache these files too.
127 -- See why we need 'fixWindows': https://gitlab.haskell.org/ghc/ghc/issues/16073
128 let fixWindows path = do
129 win <- windowsHost
130 version <- setting GhcVersion
131 hostOs <- cabalOsString <$> setting BuildOs
132 hostArch <- cabalArchString <$> setting BuildArch
133 let dir = hostArch ++ "-" ++ hostOs ++ "-ghc-" ++ version
134 return $ if win then path -/- "../.." -/- dir else path
135 pkgDbPath <- fixWindows =<< packageDbPath stage
136 let dir = pkgDbPath -/- takeBaseName conf
137 files <- liftIO $ getDirectoryFilesIO "." [dir -/- "**"]
138 produces files
139
140 copyConf :: [(Resource, Int)] -> Context -> FilePath -> Action ()
141 copyConf rs context@Context {..} conf = do
142 depPkgIds <- fmap stdOutToPkgIds . askWithResources rs $
143 target context (GhcPkg Dependencies stage) [pkgName package] []
144 need =<< mapM (\pkgId -> packageDbPath stage <&> (-/- pkgId <.> "conf")) depPkgIds
145 -- We should unregister if the file exists since @ghc-pkg@ will complain
146 -- about existing package: https://github.com/snowleopard/hadrian/issues/543.
147 -- Also, we don't always do the unregistration + registration to avoid
148 -- repeated work after a full build.
149 -- We do not track 'doesFileExist' since we are going to create the file if
150 -- it is currently missing. TODO: Is this the right thing to do?
151 -- See https://github.com/snowleopard/hadrian/issues/569.
152 unlessM (liftIO $ IO.doesFileExist conf) $ do
153 buildWithResources rs $
154 target context (GhcPkg Unregister stage) [pkgName package] []
155 buildWithResources rs $
156 target context (GhcPkg Copy stage) [pkgName package] [conf]
157 where
158 stdOutToPkgIds :: String -> [String]
159 stdOutToPkgIds = drop 1 . concatMap words . lines
160
161 getPackageNameFromConfFile :: FilePath -> Action String
162 getPackageNameFromConfFile conf
163 | takeBaseName conf == "rts" = return "rts"
164 | otherwise = case parseCabalName (takeBaseName conf) of
165 Left err -> error $ "getPackageNameFromConfFile: Couldn't parse " ++
166 takeBaseName conf ++ ": " ++ err
167 Right (name, _) -> return name
168
169 parseCabalName :: String -> Either String (String, Version)
170 parseCabalName = fmap f . Cabal.eitherParsec
171 where
172 f :: Cabal.PackageId -> (String, Version)
173 f pkg_id = (Cabal.unPackageName $ Cabal.pkgName pkg_id, Cabal.pkgVersion pkg_id)