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