Fix copying of fs*.h files during RTS registration (#566)
[ghc.git] / src / Hadrian / Haskell / Cabal / Parse.hs
1 {-# OPTIONS_GHC -Wno-deprecations #-}
2 -----------------------------------------------------------------------------
3 -- |
4 -- Module : Hadrian.Haskell.Cabal.Parse
5 -- Copyright : (c) Andrey Mokhov 2014-2017
6 -- License : MIT (see the file LICENSE)
7 -- Maintainer : andrey.mokhov@gmail.com
8 -- Stability : experimental
9 --
10 -- Extracting Haskell package metadata stored in Cabal files.
11 -----------------------------------------------------------------------------
12 module Hadrian.Haskell.Cabal.Parse
13 ( PackageData (..), parseCabal, parsePackageData, parseCabalPkgId
14 , configurePackage, copyPackage, registerPackage
15 ) where
16
17 import Data.List.Extra
18 import Development.Shake
19 import qualified Distribution.ModuleName as C
20 import qualified Distribution.Package as C
21 import qualified Distribution.PackageDescription as C
22 import qualified Distribution.PackageDescription.Configuration as C
23 import qualified Distribution.PackageDescription.Parsec as C
24 import qualified Distribution.Simple.Compiler as C
25 import qualified Distribution.Simple.GHC as C
26 import qualified Distribution.Simple.Program.Db as C
27 import qualified Distribution.Simple as C
28 import qualified Distribution.Simple.Program.Builtin as C
29 import qualified Distribution.Simple.Utils as C
30 import qualified Distribution.Simple.Program.Types as C
31 import qualified Distribution.Simple.Configure as C (getPersistBuildConfig)
32 import qualified Distribution.Simple.Build as C
33 import qualified Distribution.Types.ComponentRequestedSpec as C
34 import qualified Distribution.InstalledPackageInfo as Installed
35 import qualified Distribution.Simple.PackageIndex as C
36 import qualified Distribution.Types.LocalBuildInfo as C
37 import qualified Distribution.Text as C
38 import qualified Distribution.Types.MungedPackageId as C
39 import qualified Distribution.Verbosity as C
40
41 import Base
42 import Builder
43 import Context
44 import Flavour
45 import GHC.Packages
46 import Hadrian.Expression
47 import Hadrian.Haskell.Cabal.PackageData
48 import Hadrian.Haskell.Cabal.Type
49 import Hadrian.Oracles.TextFile
50 import Hadrian.Target
51 import Settings
52
53 -- | Parse the Cabal package identifier from a @.cabal@ file.
54 parseCabalPkgId :: FilePath -> IO String
55 parseCabalPkgId file = C.display . C.package . C.packageDescription <$> C.readGenericPackageDescription C.silent file
56
57 biModules :: C.PackageDescription -> (C.BuildInfo, [C.ModuleName])
58 biModules pd = go [ comp | comp@(bi,_) <-
59 (map libBiModules . maybeToList $ C.library pd) ++
60 (map exeBiModules $ C.executables pd)
61 , C.buildable bi ]
62 where
63 libBiModules lib = (C.libBuildInfo lib, C.explicitLibModules lib)
64 exeBiModules exe = (C.buildInfo exe,
65 -- If "main-is: ..." is not a .hs or .lhs file, do not
66 -- inject "Main" into the modules. This does not respect
67 -- "-main-is" ghc-arguments! See Cabal's
68 -- Distribution.Simple.GHC for the glory details.
69 if takeExtension (C.modulePath exe) `elem` [".hs", ".lhs"]
70 then C.main : C.exeModules exe
71 else C.exeModules exe)
72 go [] = error "No buildable component found."
73 go [x] = x
74 go _ = error "Cannot handle more than one buildinfo yet."
75
76 -- TODO: Add proper error handling for partiality due to Nothing/Left cases.
77 -- | Parse the Cabal file of the 'Package' from a given 'Context'. This function
78 -- reads the Cabal file, gets some information about the compiler to be used
79 -- corresponding to the 'Stage' it gets from the 'Context', and finalises the
80 -- package description it got from the Cabal file with additional information
81 -- such as platform, compiler version conditionals, and package flags.
82 parseCabal :: Context -> Action Cabal
83 parseCabal context@Context {..} = do
84 let file = unsafePkgCabalFile package
85
86 -- Read the package description from the Cabal file
87 gpd <- liftIO $ C.readGenericPackageDescription C.verbose file
88
89 -- Configure the package with the GHC for this stage
90 hcPath <- builderPath (Ghc CompileHs stage)
91 (compiler, Just platform, _pgdb) <- liftIO $
92 C.configure C.silent (Just hcPath) Nothing C.emptyProgramDb
93
94 flagList <- interpret (target context (CabalFlags stage) [] []) =<< args <$> flavour
95 let flags = foldr addFlag mempty flagList
96 where
97 addFlag :: String -> C.FlagAssignment -> C.FlagAssignment
98 addFlag ('-':name) = C.insertFlagAssignment (C.mkFlagName name) False
99 addFlag ('+':name) = C.insertFlagAssignment (C.mkFlagName name) True
100 addFlag name = C.insertFlagAssignment (C.mkFlagName name) True
101
102 let (Right (pd,_)) = C.finalizePD flags C.defaultComponentRequestedSpec
103 (const True) platform (C.compilerInfo compiler) [] gpd
104 -- depPkgs are all those packages that are needed. These should be found in
105 -- the known build packages even if they are not build in this stage.
106 let depPkgs = map (findPackageByName' . C.unPackageName . C.depPkgName)
107 $ flip C.enabledBuildDepends C.defaultComponentRequestedSpec pd
108 where
109 findPackageByName' p = fromMaybe (error msg) (findPackageByName p)
110 where
111 msg = "Failed to find package " ++ quote (show p)
112 return $ Cabal (C.unPackageName . C.pkgName . C.package $ pd)
113 (C.display . C.pkgVersion . C.package $ pd)
114 (C.synopsis pd) gpd pd depPkgs
115
116 -- | This function runs the equivalent of @cabal configure@ using the Cabal
117 -- library directly, collecting all the configuration options and flags to be
118 -- passed to Cabal before invoking it. It 'need's package database entries for
119 -- the dependencies of the package the 'Context' points to.
120 configurePackage :: Context -> Action ()
121 configurePackage context@Context {..} = do
122 putLoud $ "| Configure package " ++ quote (pkgName package)
123
124 Cabal _ _ _ gpd _pd depPkgs <- unsafeReadCabalFile context
125
126 -- Stage packages are those we have in this stage.
127 stagePkgs <- stagePackages stage
128 -- We'll need those packages in our package database.
129 deps <- sequence [ pkgConfFile (context { package = pkg })
130 | pkg <- depPkgs, pkg `elem` stagePkgs ]
131 need deps
132
133 -- Figure out what hooks we need.
134 hooks <- case C.buildType (C.flattenPackageDescription gpd) of
135 C.Configure -> pure C.autoconfUserHooks
136 -- time has a "Custom" Setup.hs, but it's actually Configure
137 -- plus a "./Setup test" hook. However, Cabal is also
138 -- "Custom", but doesn't have a configure script.
139 C.Custom -> do
140 configureExists <- doesFileExist $
141 replaceFileName (unsafePkgCabalFile package) "configure"
142 pure $ if configureExists then C.autoconfUserHooks else C.simpleUserHooks
143 -- Not quite right, but good enough for us:
144 _ | package == rts ->
145 -- Don't try to do post conf validation for rts. This will simply
146 -- not work, due to the ld-options and the Stg.h.
147 pure $ C.simpleUserHooks { C.postConf = \_ _ _ _ -> return () }
148 | otherwise -> pure C.simpleUserHooks
149
150 flavourArgs <- args <$> flavour
151 -- Compute the list of flags.
152 flagList <- interpret (target context (CabalFlags stage) [] []) flavourArgs
153 -- Compute the Cabal configurartion arguments.
154 argList <- interpret (target context (GhcCabal Conf stage) [] []) flavourArgs
155 verbosity <- getVerbosity
156 let v = if verbosity >= Loud then "-v3" else "-v0"
157 liftIO $ C.defaultMainWithHooksNoReadArgs hooks gpd
158 (argList ++ ["--flags=" ++ unwords flagList, v])
159
160 -- | Copy the 'Package' of a given 'Context' into the package database
161 -- corresponding to the 'Stage' of the 'Context'.
162 copyPackage :: Context -> Action ()
163 copyPackage context@Context {..} = do
164 putLoud $ "| Copy package " ++ quote (pkgName package)
165 Cabal _ _ _ gpd _ _ <- unsafeReadCabalFile context
166 ctxPath <- Context.contextPath context
167 pkgDbPath <- packageDbPath stage
168 verbosity <- getVerbosity
169 let v = if verbosity >= Loud then "-v3" else "-v0"
170 liftIO $ C.defaultMainWithHooksNoReadArgs C.autoconfUserHooks gpd
171 [ "copy", "--builddir", ctxPath, "--target-package-db", pkgDbPath, v ]
172
173 -- | Register the 'Package' of a given 'Context' into the package database.
174 registerPackage :: Context -> Action ()
175 registerPackage context@Context {..} = do
176 putLoud $ "| Register package " ++ quote (pkgName package)
177 ctxPath <- Context.contextPath context
178 Cabal _ _ _ gpd _ _ <- unsafeReadCabalFile context
179 verbosity <- getVerbosity
180 let v = if verbosity >= Loud then "-v3" else "-v0"
181 liftIO $ C.defaultMainWithHooksNoReadArgs C.autoconfUserHooks gpd
182 [ "register", "--builddir", ctxPath, v ]
183
184 -- | Parse the 'PackageData' of the 'Package' of a given 'Context'.
185 parsePackageData :: Context -> Action PackageData
186 parsePackageData context@Context {..} = do
187 -- XXX: This is conceptually wrong!
188 -- We should use the gpd, the flagAssignment and compiler, hostPlatform, ...
189 -- information from the lbi. And then compute the finalised PD (flags,
190 -- satisfiable dependencies, platform, compiler info, deps, gpd.)
191 --
192 -- let (Right (pd,_)) = C.finalizePackageDescription flags (const True) platform (compilerInfo compiler) [] gpd
193 --
194 -- However when using the new-build path's this might change.
195 Cabal _ _ _ _gpd pd _depPkgs <- unsafeReadCabalFile context
196
197 cPath <- Context.contextPath context
198 need [cPath -/- "setup-config"]
199
200 lbi <- liftIO $ C.getPersistBuildConfig cPath
201
202 -- XXX: move this into its own rule for "build/autogen/cabal_macros.h", and
203 -- "build/autogen/Path_*.hs" and 'need' them here.
204 -- create the cabal_macros.h, ...
205 -- Note: the `cPath` is ignored. The path that's used is the 'buildDir' path
206 -- from the local build info (lbi).
207 pdi <- liftIO $ getHookedBuildInfo (pkgPath package)
208 let pd' = C.updatePackageDescription pdi pd
209 lbi' = lbi { C.localPkgDescr = pd' }
210 liftIO $ C.initialBuildSteps cPath pd' lbi' C.silent
211
212 -- TODO: Get rid of deprecated 'externalPackageDeps' and drop -Wno-deprecations
213 -- See: https://github.com/snowleopard/hadrian/issues/548
214 let extDeps = C.externalPackageDeps lbi'
215 deps = map (C.display . snd) extDeps
216 dep_direct = map (fromMaybe (error "dep_keys failed")
217 . C.lookupUnitId (C.installedPkgs lbi')
218 . fst) extDeps
219 dep_ipids = map (C.display . Installed.installedUnitId) dep_direct
220
221 Just ghcProg = C.lookupProgram C.ghcProgram (C.withPrograms lbi')
222
223 dep_pkgs = C.topologicalOrder (packageHacks (C.installedPkgs lbi'))
224 forDeps f = concatMap f dep_pkgs
225
226 -- Copied from Distribution.Simple.PreProcess.ppHsc2Hs
227 packageHacks = case C.compilerFlavor (C.compiler lbi') of
228 C.GHC | C.pkgName (C.package pd') /= (C.mkPackageName "rts") -> hackRtsPackage
229 _ -> id
230 -- We don't link in the actual Haskell libraries of our dependencies, so
231 -- the -u flags in the ldOptions of the rts package mean linking fails
232 -- on OS X (it's ld is a tad stricter than gnu ld). Thus we remove the
233 -- ldOptions for GHC's rts package:
234 hackRtsPackage index | null (C.allPackages index) = index
235 -- ^ do not hack the empty index
236 hackRtsPackage index = case C.lookupPackageName index (C.mkPackageName "rts") of
237 [(_,[rts])] -> C.insert rts {
238 Installed.ldOptions = [],
239 Installed.libraryDirs = filter (not . ("gcc-lib" `isSuffixOf`))
240 (Installed.libraryDirs rts)} index
241 -- GHC <= 6.12 had $topdir/gcc-lib in their library-dirs for the rts
242 -- package, which causes problems when we try to use the in-tree
243 -- mingw, due to accidentally picking up the incompatible libraries
244 -- there. So we filter out gcc-lib from the RTS's library-dirs here.
245 _ -> error "No (or multiple) GHC rts package is registered!"
246
247 in return $ PackageData
248 { dependencies = deps
249 , name = C.unPackageName . C.pkgName . C.package $ pd'
250 , version = C.display . C.pkgVersion . C.package $ pd'
251 , componentId = C.localCompatPackageKey lbi'
252 , modules = map C.display . snd . biModules $ pd'
253 , otherModules = map C.display . C.otherModules . fst . biModules $ pd'
254 , synopsis = C.synopsis pd'
255 , description = C.description pd'
256 , srcDirs = C.hsSourceDirs . fst . biModules $ pd'
257 , deps = deps
258 , depIpIds = dep_ipids
259 , depNames = map (C.display . C.mungedName . snd) extDeps
260 , depCompIds = if C.packageKeySupported (C.compiler lbi')
261 then dep_ipids
262 else deps
263 , includeDirs = C.includeDirs . fst . biModules $ pd'
264 , includes = C.includes . fst . biModules $ pd'
265 , installIncludes = C.installIncludes . fst . biModules $ pd'
266 , extraLibs = C.extraLibs . fst . biModules $ pd'
267 , extraLibDirs = C.extraLibDirs . fst . biModules $ pd'
268 , asmSrcs = C.asmSources . fst . biModules $ pd'
269 , cSrcs = C.cSources . fst . biModules $ pd'
270 , cmmSrcs = C.cmmSources . fst . biModules $ pd'
271 , dataFiles = C.dataFiles pd'
272 , hcOpts = C.programDefaultArgs ghcProg
273 ++ (C.hcOptions C.GHC . fst . biModules $ pd')
274 ++ C.languageToFlags (C.compiler lbi') (C.defaultLanguage . fst $ biModules pd')
275 ++ C.extensionsToFlags (C.compiler lbi') (C.usedExtensions . fst $ biModules pd')
276 ++ C.programOverrideArgs ghcProg
277 , asmOpts = C.asmOptions . fst $ biModules pd'
278 , ccOpts = C.ccOptions . fst $ biModules pd'
279 , cmmOpts = C.cmmOptions . fst $ biModules pd'
280 , cppOpts = C.cppOptions . fst $ biModules pd'
281 , ldOpts = C.ldOptions . fst $ biModules pd'
282 , depIncludeDirs = forDeps Installed.includeDirs
283 , depCcOpts = forDeps Installed.ccOptions
284 , depLdOpts = forDeps Installed.ldOptions
285 , buildGhciLib = C.withGHCiLib lbi' }
286
287 getHookedBuildInfo :: FilePath -> IO C.HookedBuildInfo
288 getHookedBuildInfo baseDir = do
289 -- TODO: We should probably better generate this in the build dir, rather then
290 -- in the base dir? However `configure` is run in the baseDir.
291 maybeInfoFile <- C.findHookedPackageDesc baseDir
292 case maybeInfoFile of
293 Nothing -> return C.emptyHookedBuildInfo
294 Just infoFile -> C.readHookedBuildInfo C.silent infoFile