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