9e6b875236934970bae5cd9956838bff2348ee0e
[hadrian.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 -- Compute the list of flags
151 -- Compute the Cabal configurartion arguments
152 flavourArgs <- args <$> flavour
153 flagList <- interpret (target context (CabalFlags stage) [] []) flavourArgs
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 -- TODO: This is conceptually wrong!
188 -- We should use the gpd, the flagAssignment and compiler, hostPlatform, and
189 -- other 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 -- TODO: 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 "parsePackageData: dep_keys failed")
217 . C.lookupUnitId (C.installedPkgs lbi') . fst) extDeps
218 dep_ipids = map (C.display . Installed.installedUnitId) dep_direct
219 Just ghcProg = C.lookupProgram C.ghcProgram (C.withPrograms lbi')
220 dep_pkgs = C.topologicalOrder (packageHacks (C.installedPkgs lbi'))
221 forDeps f = concatMap f dep_pkgs
222
223 -- Copied from Distribution.Simple.PreProcess.ppHsc2Hs
224 packageHacks = case C.compilerFlavor (C.compiler lbi') of
225 C.GHC | C.pkgName (C.package pd') /= (C.mkPackageName "rts") -> hackRtsPackage
226 _ -> id
227
228 -- TODO: Get rid of this hack.
229 -- We don't link in the actual Haskell libraries of our dependencies, so
230 -- the "-u" flags in @ldOptions@ of the @rts@ package mean linking fails
231 -- on OS X (its @ld@ is a tad stricter than GNU @ld@). Thus we remove
232 -- @ldOptions@ for the @rts@ package. With one exception (see below).
233 hackRtsPackage index | null (C.allPackages index) = index
234 -- ^ do not hack the empty index
235 hackRtsPackage index = case C.lookupPackageName index (C.mkPackageName "rts") of
236 [(_,[rts])] -> C.insert rts {
237 Installed.ldOptions = [],
238 Installed.libraryDirs = filter (not . ("gcc-lib" `isSuffixOf`))
239 (Installed.libraryDirs rts)} index
240 -- GHC <= 6.12 had $topdir/gcc-lib in their library-dirs for the rts
241 -- package, which causes problems when we try to use the in-tree
242 -- mingw, due to accidentally picking up the incompatible libraries
243 -- there. So we filter out gcc-lib from the RTS's library-dirs here.
244 _ -> error "No (or multiple) GHC rts package is registered!"
245
246 buildInfo = fst (biModules pd')
247
248 in return $ PackageData
249 { dependencies = deps
250 , name = C.unPackageName . C.pkgName . C.package $ pd'
251 , version = C.display . C.pkgVersion . C.package $ pd'
252 , componentId = C.localCompatPackageKey lbi'
253 , modules = map C.display . snd . biModules $ pd'
254 , otherModules = map C.display . C.otherModules $ buildInfo
255 , synopsis = C.synopsis pd'
256 , description = C.description pd'
257 , srcDirs = C.hsSourceDirs buildInfo
258 , deps = deps
259 , depIpIds = dep_ipids
260 , depNames = map (C.display . C.mungedName . snd) extDeps
261 , depCompIds = if C.packageKeySupported (C.compiler lbi')
262 then dep_ipids
263 else deps
264 , includeDirs = C.includeDirs buildInfo
265 , includes = C.includes buildInfo
266 , installIncludes = C.installIncludes buildInfo
267 , extraLibs = C.extraLibs buildInfo
268 , extraLibDirs = C.extraLibDirs buildInfo
269 , asmSrcs = C.asmSources buildInfo
270 , cSrcs = C.cSources buildInfo
271 , cmmSrcs = C.cmmSources buildInfo
272 , dataFiles = C.dataFiles pd'
273 , hcOpts = C.programDefaultArgs ghcProg
274 ++ C.hcOptions C.GHC buildInfo
275 ++ C.languageToFlags (C.compiler lbi') (C.defaultLanguage buildInfo)
276 ++ C.extensionsToFlags (C.compiler lbi') (C.usedExtensions buildInfo)
277 ++ C.programOverrideArgs ghcProg
278 , asmOpts = C.asmOptions buildInfo
279 , ccOpts = C.ccOptions buildInfo
280 , cmmOpts = C.cmmOptions buildInfo
281 , cppOpts = C.cppOptions buildInfo
282 , ldOpts = C.ldOptions buildInfo
283 , depIncludeDirs = forDeps Installed.includeDirs
284 , depCcOpts = forDeps Installed.ccOptions
285 , depLdOpts = forDeps Installed.ldOptions
286 , buildGhciLib = C.withGHCiLib lbi' }
287
288 getHookedBuildInfo :: FilePath -> IO C.HookedBuildInfo
289 getHookedBuildInfo baseDir = do
290 -- TODO: We should probably better generate this in the build dir, rather
291 -- than in the base dir? However, @configure@ is run in the baseDir.
292 maybeInfoFile <- C.findHookedPackageDesc baseDir
293 case maybeInfoFile of
294 Nothing -> return C.emptyHookedBuildInfo
295 Just infoFile -> C.readHookedBuildInfo C.silent infoFile