931c121babbb1474a219163f0967764db29a854b
[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 liftIO $ C.defaultMainWithHooksNoReadArgs hooks gpd
156 (argList ++ ["--flags=" ++ unwords flagList])
157
158 -- | Copy the 'Package' of a given 'Context' into the package database
159 -- corresponding to the 'Stage' of the 'Context'.
160 copyPackage :: Context -> Action ()
161 copyPackage context@Context {..} = do
162 putLoud $ "| Copy package " ++ quote (pkgName package)
163 Cabal _ _ _ gpd _ _ <- unsafeReadCabalFile context
164 ctxPath <- Context.contextPath context
165 pkgDbPath <- packageDbPath stage
166 liftIO $ C.defaultMainWithHooksNoReadArgs C.autoconfUserHooks gpd
167 [ "copy", "--builddir", ctxPath, "--target-package-db", pkgDbPath ]
168
169 -- | Register the 'Package' of a given 'Context' into the package database.
170 registerPackage :: Context -> Action ()
171 registerPackage context@Context {..} = do
172 putLoud $ "| Register package " ++ quote (pkgName package)
173 ctxPath <- Context.contextPath context
174 Cabal _ _ _ gpd _ _ <- unsafeReadCabalFile context
175 liftIO $ C.defaultMainWithHooksNoReadArgs C.autoconfUserHooks gpd
176 [ "register", "--builddir", ctxPath ]
177
178 -- | Parse the 'PackageData' of the 'Package' of a given 'Context'.
179 parsePackageData :: Context -> Action PackageData
180 parsePackageData context@Context {..} = do
181 -- XXX: This is conceptually wrong!
182 -- We should use the gpd, the flagAssignment and compiler, hostPlatform, ...
183 -- information from the lbi. And then compute the finalised PD (flags,
184 -- satisfiable dependencies, platform, compiler info, deps, gpd.)
185 --
186 -- let (Right (pd,_)) = C.finalizePackageDescription flags (const True) platform (compilerInfo compiler) [] gpd
187 --
188 -- However when using the new-build path's this might change.
189 Cabal _ _ _ _gpd pd _depPkgs <- unsafeReadCabalFile context
190
191 cPath <- Context.contextPath context
192 need [cPath -/- "setup-config"]
193
194 lbi <- liftIO $ C.getPersistBuildConfig cPath
195
196 -- XXX: move this into its own rule for "build/autogen/cabal_macros.h", and
197 -- "build/autogen/Path_*.hs" and 'need' them here.
198 -- create the cabal_macros.h, ...
199 -- Note: the `cPath` is ignored. The path that's used is the 'buildDir' path
200 -- from the local build info (lbi).
201 pdi <- liftIO $ getHookedBuildInfo (pkgPath package)
202 let pd' = C.updatePackageDescription pdi pd
203 lbi' = lbi { C.localPkgDescr = pd' }
204 liftIO $ C.initialBuildSteps cPath pd' lbi' C.silent
205
206 -- TODO: Get rid of deprecated 'externalPackageDeps' and drop -Wno-deprecations
207 -- See: https://github.com/snowleopard/hadrian/issues/548
208 let extDeps = C.externalPackageDeps lbi'
209 deps = map (C.display . snd) extDeps
210 dep_direct = map (fromMaybe (error "dep_keys failed")
211 . C.lookupUnitId (C.installedPkgs lbi')
212 . fst) extDeps
213 dep_ipids = map (C.display . Installed.installedUnitId) dep_direct
214
215 Just ghcProg = C.lookupProgram C.ghcProgram (C.withPrograms lbi')
216
217 dep_pkgs = C.topologicalOrder (packageHacks (C.installedPkgs lbi'))
218 forDeps f = concatMap f dep_pkgs
219
220 -- Copied from Distribution.Simple.PreProcess.ppHsc2Hs
221 packageHacks = case C.compilerFlavor (C.compiler lbi') of
222 C.GHC | C.pkgName (C.package pd') /= (C.mkPackageName "rts") -> hackRtsPackage
223 _ -> id
224 -- We don't link in the actual Haskell libraries of our dependencies, so
225 -- the -u flags in the ldOptions of the rts package mean linking fails
226 -- on OS X (it's ld is a tad stricter than gnu ld). Thus we remove the
227 -- ldOptions for GHC's rts package:
228 hackRtsPackage index | null (C.allPackages index) = index
229 -- ^ do not hack the empty index
230 hackRtsPackage index = case C.lookupPackageName index (C.mkPackageName "rts") of
231 [(_,[rts])] -> C.insert rts {
232 Installed.ldOptions = [],
233 Installed.libraryDirs = filter (not . ("gcc-lib" `isSuffixOf`))
234 (Installed.libraryDirs rts)} index
235 -- GHC <= 6.12 had $topdir/gcc-lib in their library-dirs for the rts
236 -- package, which causes problems when we try to use the in-tree
237 -- mingw, due to accidentally picking up the incompatible libraries
238 -- there. So we filter out gcc-lib from the RTS's library-dirs here.
239 _ -> error "No (or multiple) GHC rts package is registered!"
240
241 in return $ PackageData
242 { dependencies = deps
243 , name = C.unPackageName . C.pkgName . C.package $ pd'
244 , version = C.display . C.pkgVersion . C.package $ pd'
245 , componentId = C.localCompatPackageKey lbi'
246 , modules = map C.display . snd . biModules $ pd'
247 , otherModules = map C.display . C.otherModules . fst . biModules $ pd'
248 , synopsis = C.synopsis pd'
249 , description = C.description pd'
250 , srcDirs = C.hsSourceDirs . fst . biModules $ pd'
251 , deps = deps
252 , depIpIds = dep_ipids
253 , depNames = map (C.display . C.mungedName . snd) extDeps
254 , depCompIds = if C.packageKeySupported (C.compiler lbi')
255 then dep_ipids
256 else deps
257 , includeDirs = C.includeDirs . fst . biModules $ pd'
258 , includes = C.includes . fst . biModules $ pd'
259 , installIncludes = C.installIncludes . fst . biModules $ pd'
260 , extraLibs = C.extraLibs . fst . biModules $ pd'
261 , extraLibDirs = C.extraLibDirs . fst . biModules $ pd'
262 , asmSrcs = C.asmSources . fst . biModules $ pd'
263 , cSrcs = C.cSources . fst . biModules $ pd'
264 , cmmSrcs = C.cmmSources . fst . biModules $ pd'
265 , dataFiles = C.dataFiles pd'
266 , hcOpts = C.programDefaultArgs ghcProg
267 ++ (C.hcOptions C.GHC . fst . biModules $ pd')
268 ++ C.languageToFlags (C.compiler lbi') (C.defaultLanguage . fst $ biModules pd')
269 ++ C.extensionsToFlags (C.compiler lbi') (C.usedExtensions . fst $ biModules pd')
270 ++ C.programOverrideArgs ghcProg
271 , asmOpts = C.asmOptions . fst $ biModules pd'
272 , ccOpts = C.ccOptions . fst $ biModules pd'
273 , cmmOpts = C.cmmOptions . fst $ biModules pd'
274 , cppOpts = C.cppOptions . fst $ biModules pd'
275 , ldOpts = C.ldOptions . fst $ biModules pd'
276 , depIncludeDirs = forDeps Installed.includeDirs
277 , depCcOpts = forDeps Installed.ccOptions
278 , depLdOpts = forDeps Installed.ldOptions
279 , buildGhciLib = C.withGHCiLib lbi' }
280
281 getHookedBuildInfo :: FilePath -> IO C.HookedBuildInfo
282 getHookedBuildInfo baseDir = do
283 -- TODO: We should probably better generate this in the build dir, rather then
284 -- in the base dir? However `configure` is run in the baseDir.
285 maybeInfoFile <- C.findHookedPackageDesc baseDir
286 case maybeInfoFile of
287 Nothing -> return C.emptyHookedBuildInfo
288 Just infoFile -> C.readHookedBuildInfo C.silent infoFile