Hadrian: trace the execution of expensive Cabal calls
[ghc.git] / hadrian / 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 parsePackageData, resolveContextData, parseCabalPkgId, configurePackage,
14 buildAutogenFiles, copyPackage, registerPackage
15 ) where
16
17 import Data.Bifunctor
18 import Data.List.Extra
19 import Development.Shake
20 import qualified Distribution.ModuleName as C
21 import qualified Distribution.Package as C
22 import qualified Distribution.PackageDescription as C
23 import qualified Distribution.PackageDescription.Configuration as C
24 import qualified Distribution.PackageDescription.Parsec as C
25 import qualified Distribution.Simple.Compiler 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.Text as C
37 import qualified Distribution.Types.LocalBuildInfo as C
38 import qualified Distribution.Types.CondTree as C
39 import qualified Distribution.Types.MungedPackageId as C
40 import qualified Distribution.Verbosity as C
41 import Hadrian.Expression
42 import Hadrian.Haskell.Cabal
43 import Hadrian.Haskell.Cabal.Type
44 import Hadrian.Oracles.Cabal
45 import Hadrian.Target
46
47 import Base
48 import Builder
49 import Context
50 import Flavour
51 import Packages
52 import Settings
53
54 -- | Parse the Cabal file of a given 'Package'. This operation is cached by the
55 -- "Hadrian.Oracles.TextFile.readPackageData" oracle.
56 parsePackageData :: Package -> Action PackageData
57 parsePackageData pkg = do
58 gpd <- traced "cabal-read" $
59 C.readGenericPackageDescription C.verbose (pkgCabalFile pkg)
60 let pd = C.packageDescription gpd
61 pkgId = C.package pd
62 name = C.unPackageName (C.pkgName pkgId)
63 version = C.display (C.pkgVersion pkgId)
64 libDeps = collectDeps (C.condLibrary gpd)
65 exeDeps = map (collectDeps . Just . snd) (C.condExecutables gpd)
66 allDeps = concat (libDeps : exeDeps)
67 sorted = sort [ C.unPackageName p | C.Dependency p _ _ <- allDeps ]
68 deps = nubOrd sorted \\ [name]
69 depPkgs = catMaybes $ map findPackageByName deps
70 return $ PackageData name version (C.synopsis pd) (C.description pd) depPkgs gpd
71 where
72 -- Collect an overapproximation of dependencies by ignoring conditionals
73 collectDeps :: Maybe (C.CondTree v [C.Dependency] a) -> [C.Dependency]
74 collectDeps Nothing = []
75 collectDeps (Just (C.CondNode _ deps ifs)) = deps ++ concatMap f ifs
76 where
77 f (C.CondBranch _ t mt) = collectDeps (Just t) ++ collectDeps mt
78
79 -- | Parse the package identifier from a Cabal file.
80 parseCabalPkgId :: FilePath -> IO String
81 parseCabalPkgId file = C.display . C.package . C.packageDescription <$> C.readGenericPackageDescription C.silent file
82
83 biModules :: C.PackageDescription -> (C.BuildInfo, [C.ModuleName], Maybe (C.ModuleName, String))
84 biModules pd = go [ comp | comp@(bi,_,_) <-
85 (map libBiModules . maybeToList $ C.library pd) ++
86 (map exeBiModules $ C.executables pd)
87 , C.buildable bi ]
88 where
89 libBiModules lib = (C.libBuildInfo lib, C.explicitLibModules lib, Nothing)
90 exeBiModules exe = (C.buildInfo exe,
91 -- If "main-is: ..." is not a .hs or .lhs file, do not
92 -- inject "Main" into the modules. This does not respect
93 -- "-main-is" ghc-arguments! See Cabal's
94 -- Distribution.Simple.GHC for the glory details.
95 if takeExtension (C.modulePath exe) `elem` [".hs", ".lhs"]
96 then C.main : C.exeModules exe
97 -- The module `Main` still need to be kept in `modules` of PD.
98 else C.exeModules exe,
99 Just (C.main, C.modulePath exe))
100 go [] = error "No buildable component found."
101 go [x] = x
102 go _ = error "Cannot handle more than one buildinfo yet."
103
104 -- TODO: Track command line arguments and package configuration flags.
105 -- | Configure a package using the Cabal library by collecting all the command
106 -- line arguments (to be passed to the setup script) and package configuration
107 -- flags. The function 'need's package database entries for the dependencies of
108 -- the package the 'Context' points to.
109 configurePackage :: Context -> Action ()
110 configurePackage context@Context {..} = do
111 putProgressInfo $ "| Configure package " ++ quote (pkgName package)
112 gpd <- pkgGenericDescription package
113 depPkgs <- packageDependencies <$> readPackageData package
114
115 -- Stage packages are those we have in this stage.
116 stagePkgs <- stagePackages stage
117 -- We'll need those packages in our package database.
118 deps <- sequence [ pkgConfFile (context { package = pkg })
119 | pkg <- depPkgs, pkg `elem` stagePkgs ]
120 need deps
121
122 -- Figure out what hooks we need.
123 hooks <- case C.buildType (C.flattenPackageDescription gpd) of
124 C.Configure -> pure C.autoconfUserHooks
125 -- The 'time' package has a 'C.Custom' Setup.hs, but it's actually
126 -- 'C.Configure' plus a @./Setup test@ hook. However, Cabal is also
127 -- 'C.Custom', but doesn't have a configure script.
128 C.Custom -> do
129 configureExists <- doesFileExist $
130 replaceFileName (pkgCabalFile package) "configure"
131 pure $ if configureExists then C.autoconfUserHooks else C.simpleUserHooks
132 -- Not quite right, but good enough for us:
133 _ | package == rts ->
134 -- Don't try to do post configuration validation for 'rts'. This
135 -- will simply not work, due to the @ld-options@ and @Stg.h@.
136 pure $ C.simpleUserHooks { C.postConf = \_ _ _ _ -> return () }
137 | otherwise -> pure C.simpleUserHooks
138
139 -- Compute the list of flags, and the Cabal configurartion arguments
140 flavourArgs <- args <$> flavour
141 flagList <- interpret (target context (Cabal Flags stage) [] []) flavourArgs
142 argList <- interpret (target context (Cabal Setup stage) [] []) flavourArgs
143 verbosity <- getVerbosity
144 let v = if verbosity >= Loud then "-v3" else "-v0"
145 traced "cabal-configure" $
146 C.defaultMainWithHooksNoReadArgs hooks gpd
147 (argList ++ ["--flags=" ++ unwords flagList, v])
148
149 dir <- Context.buildPath context
150 files <- liftIO $ getDirectoryFilesIO "." [ dir -/- "include" <//> "*"
151 , dir -/- "*.buildinfo"
152 , dir -/- "lib" <//> "*"
153 , dir -/- "config.*" ]
154 produces files
155
156 -- | Copy the 'Package' of a given 'Context' into the package database
157 -- corresponding to the 'Stage' of the 'Context'.
158 copyPackage :: Context -> Action ()
159 copyPackage context@Context {..} = do
160 putProgressInfo $ "| Copy package " ++ quote (pkgName package)
161 gpd <- pkgGenericDescription package
162 ctxPath <- Context.contextPath context
163 pkgDbPath <- packageDbPath stage
164 verbosity <- getVerbosity
165 let v = if verbosity >= Loud then "-v3" else "-v0"
166 traced "cabal-copy" $
167 C.defaultMainWithHooksNoReadArgs C.autoconfUserHooks gpd
168 [ "copy", "--builddir", ctxPath, "--target-package-db", pkgDbPath, v ]
169
170 -- | Register the 'Package' of a given 'Context' into the package database.
171 registerPackage :: Context -> Action ()
172 registerPackage context@Context {..} = do
173 putProgressInfo $ "| Register package " ++ quote (pkgName package)
174 ctxPath <- Context.contextPath context
175 gpd <- pkgGenericDescription package
176 verbosity <- getVerbosity
177 let v = if verbosity >= Loud then "-v3" else "-v0"
178 traced "cabal-register" $
179 C.defaultMainWithHooksNoReadArgs C.autoconfUserHooks gpd
180 [ "register", "--builddir", ctxPath, v ]
181
182 -- | Parse the 'ContextData' of a given 'Context'.
183 resolveContextData :: Context -> Action ContextData
184 resolveContextData context@Context {..} = do
185 -- TODO: This is conceptually wrong!
186 -- We should use the gpd, the flagAssignment and compiler, hostPlatform, and
187 -- other information from the lbi. And then compute the finalised PD (flags,
188 -- satisfiable dependencies, platform, compiler info, deps, gpd).
189 --
190 -- let (Right (pd,_)) = C.finalizePackageDescription flags (const True) platform (compilerInfo compiler) [] gpd
191 --
192 -- However when using the new-build path's this might change.
193
194 -- Read the package description from the Cabal file
195 gpd <- genericPackageDescription <$> readPackageData package
196
197 -- Configure the package with the GHC for this stage
198 (compiler, platform) <- configurePackageGHC package stage
199
200 flagList <- interpret (target context (Cabal Flags stage) [] []) =<< args <$> flavour
201 let flags = foldr addFlag mempty flagList
202 where
203 addFlag :: String -> C.FlagAssignment -> C.FlagAssignment
204 addFlag ('-':name) = C.insertFlagAssignment (C.mkFlagName name) False
205 addFlag ('+':name) = C.insertFlagAssignment (C.mkFlagName name) True
206 addFlag name = C.insertFlagAssignment (C.mkFlagName name) True
207
208 let (Right (pd,_)) = C.finalizePD flags C.defaultComponentRequestedSpec
209 (const True) platform (C.compilerInfo compiler) [] gpd
210
211 cPath <- Context.contextPath context
212 lbi <- liftIO $ C.getPersistBuildConfig cPath
213
214 -- Note: the @cPath@ is ignored. The path that's used is the 'buildDir' path
215 -- from the local build info @lbi@.
216 pdi <- liftIO $ getHookedBuildInfo [pkgPath package, cPath -/- "build"]
217 let pd' = C.updatePackageDescription pdi pd
218 lbi' = lbi { C.localPkgDescr = pd' }
219
220 -- TODO: Get rid of deprecated 'externalPackageDeps' and drop -Wno-deprecations
221 -- See: https://github.com/snowleopard/hadrian/issues/548
222 let extDeps = C.externalPackageDeps lbi'
223 deps = map (C.display . snd) extDeps
224 depDirect = map (fromMaybe (error "resolveContextData: depDirect failed")
225 . C.lookupUnitId (C.installedPkgs lbi') . fst) extDeps
226 depIds = map (C.display . Installed.installedUnitId) depDirect
227 Just ghcProg = C.lookupProgram C.ghcProgram (C.withPrograms lbi')
228 depPkgs = C.topologicalOrder (packageHacks (C.installedPkgs lbi'))
229 forDeps f = concatMap f depPkgs
230
231 -- Copied from Distribution.Simple.PreProcess.ppHsc2Hs
232 packageHacks = case C.compilerFlavor (C.compiler lbi') of
233 C.GHC | C.pkgName (C.package pd') /= (C.mkPackageName "rts") -> hackRtsPackage
234 _ -> id
235
236 -- TODO: Get rid of this hack.
237 -- We don't link in the actual Haskell libraries of our dependencies, so
238 -- the "-u" flags in @ldOptions@ of the @rts@ package mean linking fails
239 -- on OS X (its @ld@ is a tad stricter than GNU @ld@). Thus we remove
240 -- @ldOptions@ for the @rts@ package. With one exception (see below).
241 hackRtsPackage index | null (C.allPackages index) = index
242 -- ^ do not hack the empty index
243 hackRtsPackage index = case C.lookupPackageName index (C.mkPackageName "rts") of
244 [(_, [rts])] -> C.insert rts {
245 Installed.ldOptions = [],
246 Installed.libraryDirs = filter (not . ("gcc-lib" `isSuffixOf`))
247 (Installed.libraryDirs rts)} index
248 -- GHC <= 6.12 had @$topdir/gcc-lib@ in their @library-dirs@ for the
249 -- 'rts' package, which causes problems when we try to use the
250 -- in-tree @mingw@, due to accidentally picking up the incompatible
251 -- libraries there. So we filter out @gcc-lib@ from the RTS's
252 -- @library-dirs@ here.
253 _ -> error "No (or multiple) GHC rts package is registered!"
254
255 (buildInfo, modules, mainIs) = biModules pd'
256
257 in return $ ContextData
258 { dependencies = deps
259 , componentId = C.localCompatPackageKey lbi'
260 , mainIs = fmap (first C.display) mainIs
261 , modules = map C.display modules
262 , otherModules = map C.display $ C.otherModules buildInfo
263 , srcDirs = C.hsSourceDirs buildInfo
264 , depIds = depIds
265 , depNames = map (C.display . C.mungedName . snd) extDeps
266 , includeDirs = C.includeDirs buildInfo
267 , includes = C.includes buildInfo
268 , installIncludes = C.installIncludes buildInfo
269 , extraLibs = C.extraLibs buildInfo
270 , extraLibDirs = C.extraLibDirs buildInfo
271 , asmSrcs = C.asmSources buildInfo
272 , cSrcs = C.cSources buildInfo
273 , cmmSrcs = C.cmmSources buildInfo
274 , hcOpts = C.programDefaultArgs ghcProg
275 ++ C.hcOptions C.GHC buildInfo
276 ++ C.languageToFlags (C.compiler lbi') (C.defaultLanguage buildInfo)
277 ++ C.extensionsToFlags (C.compiler lbi') (C.usedExtensions buildInfo)
278 ++ C.programOverrideArgs ghcProg
279 , asmOpts = C.asmOptions buildInfo
280 , ccOpts = C.ccOptions buildInfo
281 , cmmOpts = C.cmmOptions buildInfo
282 , cppOpts = C.cppOptions buildInfo
283 , ldOpts = C.ldOptions buildInfo
284 , depIncludeDirs = forDeps Installed.includeDirs
285 , depCcOpts = forDeps Installed.ccOptions
286 , depLdOpts = forDeps Installed.ldOptions
287 , buildGhciLib = C.withGHCiLib lbi'
288 , frameworks = C.frameworks buildInfo
289 , packageDescription = pd' }
290
291 -- | Build autogenerated files @autogen/cabal_macros.h@ and @autogen/Paths_*.hs@.
292 buildAutogenFiles :: Context -> Action ()
293 buildAutogenFiles context = do
294 cPath <- Context.contextPath context
295 setupConfig <- pkgSetupConfigFile context
296 need [setupConfig] -- This triggers 'configurePackage'
297 pd <- packageDescription <$> readContextData context
298 -- Note: the @cPath@ is ignored. The path that's used is the 'buildDir' path
299 -- from the local build info @lbi@.
300 traced "cabal-autogen" $ do
301 lbi <- C.getPersistBuildConfig cPath
302 C.initialBuildSteps cPath pd (lbi { C.localPkgDescr = pd }) C.silent
303
304 -- | Look for a @.buildinfo@ in all of the specified directories, stopping on
305 -- the first one we find.
306 getHookedBuildInfo :: [FilePath] -> IO C.HookedBuildInfo
307 getHookedBuildInfo [] = return C.emptyHookedBuildInfo
308 getHookedBuildInfo (baseDir:baseDirs) = do
309 maybeInfoFile <- C.findHookedPackageDesc baseDir
310 case maybeInfoFile of
311 Nothing -> getHookedBuildInfo baseDirs
312 Just infoFile -> C.readHookedBuildInfo C.silent infoFile