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