Read the `main-is` field from the cabal file for executables (#627)
[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], Maybe (C.ModuleName, String))
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, Nothing)
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 -- The module `Main` still need to be kept in `modules` of PD.
72 else C.exeModules exe,
73 Just (C.main, C.modulePath exe))
74 go [] = error "No buildable component found."
75 go [x] = x
76 go _ = error "Cannot handle more than one buildinfo yet."
77
78 -- TODO: Add proper error handling for partiality due to Nothing/Left cases.
79 -- | Parse the Cabal file of the 'Package' from a given 'Context'. This function
80 -- reads the Cabal file, gets some information about the compiler to be used
81 -- corresponding to the 'Stage' it gets from the 'Context', and finalises the
82 -- package description it got from the Cabal file with additional information
83 -- such as platform, compiler version conditionals, and package flags.
84 parseCabal :: Context -> Action Cabal
85 parseCabal context@Context {..} = do
86 let file = unsafePkgCabalFile package
87
88 -- Read the package description from the Cabal file
89 gpd <- liftIO $ C.readGenericPackageDescription C.verbose file
90
91 -- Configure the package with the GHC for this stage
92 hcPath <- builderPath (Ghc CompileHs stage)
93 (compiler, Just platform, _pgdb) <- liftIO $
94 C.configure C.silent (Just hcPath) Nothing C.emptyProgramDb
95
96 flagList <- interpret (target context (CabalFlags stage) [] []) =<< args <$> flavour
97 let flags = foldr addFlag mempty flagList
98 where
99 addFlag :: String -> C.FlagAssignment -> C.FlagAssignment
100 addFlag ('-':name) = C.insertFlagAssignment (C.mkFlagName name) False
101 addFlag ('+':name) = C.insertFlagAssignment (C.mkFlagName name) True
102 addFlag name = C.insertFlagAssignment (C.mkFlagName name) True
103
104 let (Right (pd,_)) = C.finalizePD flags C.defaultComponentRequestedSpec
105 (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
111 findPackageByName' p = fromMaybe (error msg) (findPackageByName p)
112 where
113 msg = "Failed to find package " ++ quote (show p)
114 return $ Cabal (C.unPackageName . C.pkgName . C.package $ pd)
115 (C.display . C.pkgVersion . C.package $ pd)
116 (C.synopsis pd) gpd pd depPkgs
117
118 -- | This function runs the equivalent of @cabal configure@ using the Cabal
119 -- library directly, collecting all the configuration options and flags to be
120 -- passed to Cabal before invoking it. It 'need's package database entries for
121 -- the dependencies of the package the 'Context' points to.
122 configurePackage :: Context -> Action ()
123 configurePackage context@Context {..} = do
124 putLoud $ "| Configure package " ++ quote (pkgName package)
125
126 Cabal _ _ _ gpd _pd depPkgs <- unsafeReadCabalFile context
127
128 -- Stage packages are those we have in this stage.
129 stagePkgs <- stagePackages stage
130 -- We'll need those packages in our package database.
131 deps <- sequence [ pkgConfFile (context { package = pkg })
132 | pkg <- depPkgs, pkg `elem` stagePkgs ]
133 need deps
134
135 -- Figure out what hooks we need.
136 hooks <- case C.buildType (C.flattenPackageDescription gpd) of
137 C.Configure -> pure C.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 -> do
142 configureExists <- doesFileExist $
143 replaceFileName (unsafePkgCabalFile package) "configure"
144 pure $ if configureExists then C.autoconfUserHooks else C.simpleUserHooks
145 -- Not quite right, but good enough for us:
146 _ | package == rts ->
147 -- Don't try to do post conf validation for rts. This will simply
148 -- not work, due to the ld-options and the Stg.h.
149 pure $ C.simpleUserHooks { C.postConf = \_ _ _ _ -> return () }
150 | otherwise -> pure C.simpleUserHooks
151
152 -- Compute the list of flags
153 -- Compute the Cabal configurartion arguments
154 flavourArgs <- args <$> flavour
155 flagList <- interpret (target context (CabalFlags stage) [] []) flavourArgs
156 argList <- interpret (target context (GhcCabal Conf stage) [] []) flavourArgs
157 verbosity <- getVerbosity
158 let v = if verbosity >= Loud then "-v3" else "-v0"
159 liftIO $ C.defaultMainWithHooksNoReadArgs hooks gpd
160 (argList ++ ["--flags=" ++ unwords flagList, v])
161
162 -- | Copy the 'Package' of a given 'Context' into the package database
163 -- corresponding to the 'Stage' of the 'Context'.
164 copyPackage :: Context -> Action ()
165 copyPackage context@Context {..} = do
166 putLoud $ "| Copy package " ++ quote (pkgName package)
167 Cabal _ _ _ gpd _ _ <- unsafeReadCabalFile context
168 ctxPath <- Context.contextPath context
169 pkgDbPath <- packageDbPath stage
170 verbosity <- getVerbosity
171 let v = if verbosity >= Loud then "-v3" else "-v0"
172 liftIO $ C.defaultMainWithHooksNoReadArgs C.autoconfUserHooks gpd
173 [ "copy", "--builddir", ctxPath, "--target-package-db", pkgDbPath, v ]
174
175 -- | Register the 'Package' of a given 'Context' into the package database.
176 registerPackage :: Context -> Action ()
177 registerPackage context@Context {..} = do
178 putLoud $ "| Register package " ++ quote (pkgName package)
179 ctxPath <- Context.contextPath context
180 Cabal _ _ _ gpd _ _ <- unsafeReadCabalFile context
181 verbosity <- getVerbosity
182 let v = if verbosity >= Loud then "-v3" else "-v0"
183 liftIO $ C.defaultMainWithHooksNoReadArgs C.autoconfUserHooks gpd
184 [ "register", "--builddir", ctxPath, v ]
185
186 -- | Parse the 'PackageData' of the 'Package' of a given 'Context'.
187 parsePackageData :: Context -> Action PackageData
188 parsePackageData context@Context {..} = do
189 -- TODO: This is conceptually wrong!
190 -- We should use the gpd, the flagAssignment and compiler, hostPlatform, and
191 -- other information from the lbi. And then compute the finalised PD (flags,
192 -- satisfiable dependencies, platform, compiler info, deps, gpd).
193 --
194 -- let (Right (pd,_)) = C.finalizePackageDescription flags (const True) platform (compilerInfo compiler) [] gpd
195 --
196 -- However when using the new-build path's this might change.
197 Cabal _ _ _ _gpd pd _depPkgs <- unsafeReadCabalFile context
198
199 cPath <- Context.contextPath context
200 need [cPath -/- "setup-config"]
201
202 lbi <- liftIO $ C.getPersistBuildConfig cPath
203
204 -- TODO: Move this into its own rule for "build/autogen/cabal_macros.h", and
205 -- "build/autogen/Path_*.hs" and 'need' them here.
206 -- create the cabal_macros.h, ...
207 -- Note: the `cPath` is ignored. The path that's used is the 'buildDir' path
208 -- from the local build info (lbi).
209 pdi <- liftIO $ getHookedBuildInfo (pkgPath package)
210 let pd' = C.updatePackageDescription pdi pd
211 lbi' = lbi { C.localPkgDescr = pd' }
212 liftIO $ C.initialBuildSteps cPath pd' lbi' C.silent
213
214 -- TODO: Get rid of deprecated 'externalPackageDeps' and drop -Wno-deprecations
215 -- See: https://github.com/snowleopard/hadrian/issues/548
216 let extDeps = C.externalPackageDeps lbi'
217 deps = map (C.display . snd) extDeps
218 dep_direct = map (fromMaybe (error "parsePackageData: dep_keys failed")
219 . C.lookupUnitId (C.installedPkgs lbi') . fst) extDeps
220 dep_ipids = map (C.display . Installed.installedUnitId) dep_direct
221 Just ghcProg = C.lookupProgram C.ghcProgram (C.withPrograms lbi')
222 dep_pkgs = C.topologicalOrder (packageHacks (C.installedPkgs lbi'))
223 forDeps f = concatMap f dep_pkgs
224
225 -- Copied from Distribution.Simple.PreProcess.ppHsc2Hs
226 packageHacks = case C.compilerFlavor (C.compiler lbi') of
227 C.GHC | C.pkgName (C.package pd') /= (C.mkPackageName "rts") -> hackRtsPackage
228 _ -> id
229
230 -- TODO: Get rid of this hack.
231 -- We don't link in the actual Haskell libraries of our dependencies, so
232 -- the "-u" flags in @ldOptions@ of the @rts@ package mean linking fails
233 -- on OS X (its @ld@ is a tad stricter than GNU @ld@). Thus we remove
234 -- @ldOptions@ for the @rts@ package. With one exception (see below).
235 hackRtsPackage index | null (C.allPackages index) = index
236 -- ^ do not hack the empty index
237 hackRtsPackage index = case C.lookupPackageName index (C.mkPackageName "rts") of
238 [(_,[rts])] -> C.insert rts {
239 Installed.ldOptions = [],
240 Installed.libraryDirs = filter (not . ("gcc-lib" `isSuffixOf`))
241 (Installed.libraryDirs rts)} index
242 -- GHC <= 6.12 had $topdir/gcc-lib in their library-dirs for the rts
243 -- package, which causes problems when we try to use the in-tree
244 -- mingw, due to accidentally picking up the incompatible libraries
245 -- there. So we filter out gcc-lib from the RTS's library-dirs here.
246 _ -> error "No (or multiple) GHC rts package is registered!"
247
248 (buildInfo, modules, mainIs) = biModules pd'
249
250 in return $ PackageData
251 { dependencies = deps
252 , name = C.unPackageName . C.pkgName . C.package $ pd'
253 , version = C.display . C.pkgVersion . C.package $ pd'
254 , componentId = C.localCompatPackageKey lbi'
255 , mainIs = case mainIs of
256 Just (mod, filepath) -> Just (C.display mod, filepath)
257 Nothing -> Nothing
258 , modules = map C.display $ modules
259 , otherModules = map C.display . C.otherModules $ buildInfo
260 , synopsis = C.synopsis pd'
261 , description = C.description pd'
262 , srcDirs = C.hsSourceDirs buildInfo
263 , deps = deps
264 , depIpIds = dep_ipids
265 , depNames = map (C.display . C.mungedName . snd) extDeps
266 , depCompIds = if C.packageKeySupported (C.compiler lbi')
267 then dep_ipids
268 else deps
269 , includeDirs = C.includeDirs buildInfo
270 , includes = C.includes buildInfo
271 , installIncludes = C.installIncludes buildInfo
272 , extraLibs = C.extraLibs buildInfo
273 , extraLibDirs = C.extraLibDirs buildInfo
274 , asmSrcs = C.asmSources buildInfo
275 , cSrcs = C.cSources buildInfo
276 , cmmSrcs = C.cmmSources buildInfo
277 , dataFiles = C.dataFiles pd'
278 , hcOpts = C.programDefaultArgs ghcProg
279 ++ C.hcOptions C.GHC buildInfo
280 ++ C.languageToFlags (C.compiler lbi') (C.defaultLanguage buildInfo)
281 ++ C.extensionsToFlags (C.compiler lbi') (C.usedExtensions buildInfo)
282 ++ C.programOverrideArgs ghcProg
283 , asmOpts = C.asmOptions buildInfo
284 , ccOpts = C.ccOptions buildInfo
285 , cmmOpts = C.cmmOptions buildInfo
286 , cppOpts = C.cppOptions buildInfo
287 , ldOpts = C.ldOptions buildInfo
288 , depIncludeDirs = forDeps Installed.includeDirs
289 , depCcOpts = forDeps Installed.ccOptions
290 , depLdOpts = forDeps Installed.ldOptions
291 , buildGhciLib = C.withGHCiLib lbi' }
292
293 getHookedBuildInfo :: FilePath -> IO C.HookedBuildInfo
294 getHookedBuildInfo baseDir = do
295 -- TODO: We should probably better generate this in the build dir, rather
296 -- than in the base dir? However, @configure@ is run in the baseDir.
297 maybeInfoFile <- C.findHookedPackageDesc baseDir
298 case maybeInfoFile of
299 Nothing -> return C.emptyHookedBuildInfo
300 Just infoFile -> C.readHookedBuildInfo C.silent infoFile