Support for abi-depends for computing shadowing.
[ghc.git] / utils / ghc-cabal / Main.hs
1 {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
2
3 module Main (main) where
4
5 import qualified Distribution.ModuleName as ModuleName
6 import Distribution.PackageDescription
7 import Distribution.PackageDescription.Check hiding (doesFileExist)
8 import Distribution.PackageDescription.Configuration
9 import Distribution.PackageDescription.Parse
10 import Distribution.Package
11 import Distribution.System
12 import Distribution.Simple
13 import Distribution.Simple.Configure
14 import Distribution.Simple.LocalBuildInfo
15 import Distribution.Simple.GHC
16 import Distribution.Simple.Program
17 import Distribution.Simple.Program.HcPkg
18 import Distribution.Simple.Setup (ConfigFlags(configStripLibs), fromFlag, toFlag)
19 import Distribution.Simple.Utils (defaultPackageDesc, writeFileAtomic, toUTF8)
20 import Distribution.Simple.Build (writeAutogenFiles)
21 import Distribution.Simple.Register
22 import Distribution.Text
23 import Distribution.Verbosity
24 import qualified Distribution.InstalledPackageInfo as Installed
25 import qualified Distribution.Simple.PackageIndex as PackageIndex
26
27 import Control.Exception (bracket)
28 import Control.Monad
29 import qualified Data.ByteString.Lazy.Char8 as BS
30 import Data.List
31 import Data.Maybe
32 import System.IO
33 import System.Directory (setCurrentDirectory, getCurrentDirectory, doesFileExist)
34 import System.Environment
35 import System.Exit (exitWith, ExitCode(..))
36 import System.FilePath
37
38 main :: IO ()
39 main = do hSetBuffering stdout LineBuffering
40 args <- getArgs
41 case args of
42 "hscolour" : dir : distDir : args' ->
43 runHsColour dir distDir args'
44 "check" : dir : [] ->
45 doCheck dir
46 "copy" : dir : distDir
47 : strip : myDestDir : myPrefix : myLibdir : myDocdir
48 : ghcLibWays : args' ->
49 doCopy dir distDir
50 strip myDestDir myPrefix myLibdir myDocdir
51 ("dyn" `elem` words ghcLibWays)
52 args'
53 "register" : dir : distDir : ghc : ghcpkg : topdir
54 : myDestDir : myPrefix : myLibdir : myDocdir
55 : relocatableBuild : args' ->
56 doRegister dir distDir ghc ghcpkg topdir
57 myDestDir myPrefix myLibdir myDocdir
58 relocatableBuild args'
59 "configure" : dir : distDir : dll0Modules : config_args ->
60 generate dir distDir dll0Modules config_args
61 "sdist" : dir : distDir : [] ->
62 doSdist dir distDir
63 ["--version"] ->
64 defaultMainArgs ["--version"]
65 _ -> die syntax_error
66
67 syntax_error :: [String]
68 syntax_error =
69 ["syntax: ghc-cabal configure <configure-args> -- <distdir> <directory>...",
70 " ghc-cabal install <ghc-pkg> <directory> <distdir> <destdir> <prefix> <args>...",
71 " ghc-cabal hscolour <distdir> <directory> <args>..."]
72
73 die :: [String] -> IO a
74 die errs = do mapM_ (hPutStrLn stderr) errs
75 exitWith (ExitFailure 1)
76
77 withCurrentDirectory :: FilePath -> IO a -> IO a
78 withCurrentDirectory directory io
79 = bracket (getCurrentDirectory) (setCurrentDirectory)
80 (const (setCurrentDirectory directory >> io))
81
82 -- We need to use the autoconfUserHooks, as the packages that use
83 -- configure can create a .buildinfo file, and we need any info that
84 -- ends up in it.
85 userHooks :: UserHooks
86 userHooks = autoconfUserHooks
87
88 runDefaultMain :: IO ()
89 runDefaultMain
90 = do let verbosity = normal
91 gpdFile <- defaultPackageDesc verbosity
92 gpd <- readPackageDescription verbosity gpdFile
93 case buildType (flattenPackageDescription gpd) of
94 Just Configure -> defaultMainWithHooks autoconfUserHooks
95 -- time has a "Custom" Setup.hs, but it's actually Configure
96 -- plus a "./Setup test" hook. However, Cabal is also
97 -- "Custom", but doesn't have a configure script.
98 Just Custom ->
99 do configureExists <- doesFileExist "configure"
100 if configureExists
101 then defaultMainWithHooks autoconfUserHooks
102 else defaultMain
103 -- not quite right, but good enough for us:
104 _ -> defaultMain
105
106 doSdist :: FilePath -> FilePath -> IO ()
107 doSdist directory distDir
108 = withCurrentDirectory directory
109 $ withArgs (["sdist", "--builddir", distDir])
110 runDefaultMain
111
112 doCheck :: FilePath -> IO ()
113 doCheck directory
114 = withCurrentDirectory directory
115 $ do let verbosity = normal
116 gpdFile <- defaultPackageDesc verbosity
117 gpd <- readPackageDescription verbosity gpdFile
118 case filter isFailure $ checkPackage gpd Nothing of
119 [] -> return ()
120 errs -> mapM_ print errs >> exitWith (ExitFailure 1)
121 where isFailure (PackageDistSuspicious {}) = False
122 isFailure (PackageDistSuspiciousWarn {}) = False
123 isFailure _ = True
124
125 runHsColour :: FilePath -> FilePath -> [String] -> IO ()
126 runHsColour directory distdir args
127 = withCurrentDirectory directory
128 $ defaultMainArgs ("hscolour" : "--builddir" : distdir : args)
129
130 doCopy :: FilePath -> FilePath
131 -> FilePath -> FilePath -> FilePath -> FilePath -> FilePath -> Bool
132 -> [String]
133 -> IO ()
134 doCopy directory distDir
135 strip myDestDir myPrefix myLibdir myDocdir withSharedLibs
136 args
137 = withCurrentDirectory directory $ do
138 let copyArgs = ["copy", "--builddir", distDir]
139 ++ (if null myDestDir
140 then []
141 else ["--destdir", myDestDir])
142 ++ args
143 copyHooks = userHooks {
144 copyHook = noGhcPrimHook
145 $ modHook False
146 $ copyHook userHooks
147 }
148
149 defaultMainWithHooksArgs copyHooks copyArgs
150 where
151 noGhcPrimHook f pd lbi us flags
152 = let pd'
153 | packageName pd == mkPackageName "ghc-prim" =
154 case library pd of
155 Just lib ->
156 let ghcPrim = fromJust (simpleParse "GHC.Prim")
157 ems = filter (ghcPrim /=) (exposedModules lib)
158 lib' = lib { exposedModules = ems }
159 in pd { library = Just lib' }
160 Nothing ->
161 error "Expected a library, but none found"
162 | otherwise = pd
163 in f pd' lbi us flags
164 modHook relocatableBuild f pd lbi us flags
165 = do let verbosity = normal
166 idts = updateInstallDirTemplates relocatableBuild
167 myPrefix myLibdir myDocdir
168 (installDirTemplates lbi)
169 progs = withPrograms lbi
170 stripProgram' = stripProgram {
171 programFindLocation = \_ _ -> return (Just (strip,[])) }
172
173 progs' <- configureProgram verbosity stripProgram' progs
174 let lbi' = lbi {
175 withPrograms = progs',
176 installDirTemplates = idts,
177 configFlags = cfg,
178 stripLibs = fromFlag (configStripLibs cfg),
179 withSharedLib = withSharedLibs
180 }
181
182 -- This hack allows to interpret the "strip"
183 -- command-line argument being set to ':' to signify
184 -- disabled library stripping
185 cfg | strip == ":" = (configFlags lbi) { configStripLibs = toFlag False }
186 | otherwise = configFlags lbi
187
188 f pd lbi' us flags
189
190 doRegister :: FilePath -> FilePath -> FilePath -> FilePath
191 -> FilePath -> FilePath -> FilePath -> FilePath -> FilePath
192 -> String -> [String]
193 -> IO ()
194 doRegister directory distDir ghc ghcpkg topdir
195 myDestDir myPrefix myLibdir myDocdir
196 relocatableBuildStr args
197 = withCurrentDirectory directory $ do
198 relocatableBuild <- case relocatableBuildStr of
199 "YES" -> return True
200 "NO" -> return False
201 _ -> die ["Bad relocatableBuildStr: " ++
202 show relocatableBuildStr]
203 let regArgs = "register" : "--builddir" : distDir : args
204 regHooks = userHooks {
205 regHook = modHook relocatableBuild
206 $ regHook userHooks
207 }
208
209 defaultMainWithHooksArgs regHooks regArgs
210 where
211 modHook relocatableBuild f pd lbi us flags
212 = do let verbosity = normal
213 idts = updateInstallDirTemplates relocatableBuild
214 myPrefix myLibdir myDocdir
215 (installDirTemplates lbi)
216 progs = withPrograms lbi
217 ghcpkgconf = topdir </> "package.conf.d"
218 ghcProgram' = ghcProgram {
219 programPostConf = \_ cp -> return cp { programDefaultArgs = ["-B" ++ topdir] },
220 programFindLocation = \_ _ -> return (Just (ghc,[])) }
221 ghcPkgProgram' = ghcPkgProgram {
222 programPostConf = \_ cp -> return cp { programDefaultArgs =
223 ["--global-package-db", ghcpkgconf]
224 ++ ["--force" | not (null myDestDir) ] },
225 programFindLocation = \_ _ -> return (Just (ghcpkg,[])) }
226 configurePrograms ps conf = foldM (flip (configureProgram verbosity)) conf ps
227
228 progs' <- configurePrograms [ghcProgram', ghcPkgProgram'] progs
229 instInfos <- dump (hcPkgInfo progs') verbosity GlobalPackageDB
230 let installedPkgs' = PackageIndex.fromList instInfos
231 let lbi' = lbi {
232 installedPkgs = installedPkgs',
233 installDirTemplates = idts,
234 withPrograms = progs'
235 }
236 f pd lbi' us flags
237
238 updateInstallDirTemplates :: Bool -> FilePath -> FilePath -> FilePath
239 -> InstallDirTemplates
240 -> InstallDirTemplates
241 updateInstallDirTemplates relocatableBuild myPrefix myLibdir myDocdir idts
242 = idts {
243 prefix = toPathTemplate $
244 if relocatableBuild
245 then "$topdir"
246 else myPrefix,
247 libdir = toPathTemplate $
248 if relocatableBuild
249 then "$topdir"
250 else myLibdir,
251 dynlibdir = toPathTemplate $
252 (if relocatableBuild
253 then "$topdir"
254 else myLibdir) </> "$libname",
255 libsubdir = toPathTemplate "$libname",
256 docdir = toPathTemplate $
257 if relocatableBuild
258 then "$topdir/../doc/html/libraries/$pkgid"
259 else (myDocdir </> "$pkgid"),
260 htmldir = toPathTemplate "$docdir"
261 }
262
263 -- On Windows we need to split the ghc package into 2 pieces, or the
264 -- DLL that it makes contains too many symbols (#5987). There are
265 -- therefore 2 libraries, not just the 1 that Cabal assumes.
266 mangleIPI :: FilePath -> FilePath -> LocalBuildInfo
267 -> Installed.InstalledPackageInfo -> Installed.InstalledPackageInfo
268 mangleIPI "compiler" "stage2" lbi ipi
269 | isWindows =
270 -- Cabal currently only ever installs ONE Haskell library, c.f.
271 -- the code in Cabal.Distribution.Simple.Register. If it
272 -- ever starts installing more we'll have to find the
273 -- library that's too big and split that.
274 let [old_hslib] = Installed.hsLibraries ipi
275 in ipi {
276 Installed.hsLibraries = [old_hslib, old_hslib ++ "-0"]
277 }
278 where isWindows = case hostPlatform lbi of
279 Platform _ Windows -> True
280 _ -> False
281 mangleIPI _ _ _ ipi = ipi
282
283 generate :: FilePath -> FilePath -> String -> [String] -> IO ()
284 generate directory distdir dll0Modules config_args
285 = withCurrentDirectory directory
286 $ do let verbosity = normal
287 -- XXX We shouldn't just configure with the default flags
288 -- XXX And this, and thus the "getPersistBuildConfig distdir" below,
289 -- aren't going to work when the deps aren't built yet
290 withArgs (["configure", "--distdir", distdir, "--ipid", "$pkg-$version"] ++ config_args)
291 runDefaultMain
292
293 lbi <- getPersistBuildConfig distdir
294 let pd0 = localPkgDescr lbi
295
296 writePersistBuildConfig distdir lbi
297
298 hooked_bi <-
299 if (buildType pd0 == Just Configure) || (buildType pd0 == Just Custom)
300 then do
301 maybe_infoFile <- defaultHookedPackageDesc
302 case maybe_infoFile of
303 Nothing -> return emptyHookedBuildInfo
304 Just infoFile -> readHookedBuildInfo verbosity infoFile
305 else
306 return emptyHookedBuildInfo
307
308 let pd = updatePackageDescription hooked_bi pd0
309
310 -- generate Paths_<pkg>.hs and cabal-macros.h
311 withAllComponentsInBuildOrder pd lbi $ \_ clbi ->
312 writeAutogenFiles verbosity pd lbi clbi
313
314 -- generate inplace-pkg-config
315 withLibLBI pd lbi $ \lib clbi ->
316 do cwd <- getCurrentDirectory
317 let ipid = mkUnitId (display (packageId pd))
318 let installedPkgInfo = inplaceInstalledPackageInfo cwd distdir
319 pd (mkAbiHash "inplace") lib lbi clbi
320 final_ipi = mangleIPI directory distdir lbi $ installedPkgInfo {
321 Installed.installedUnitId = ipid,
322 Installed.compatPackageKey = display (packageId pd),
323 Installed.haddockHTMLs = []
324 }
325 content = Installed.showInstalledPackageInfo final_ipi ++ "\n"
326 writeFileAtomic (distdir </> "inplace-pkg-config") (BS.pack $ toUTF8 content)
327
328 let
329 comp = compiler lbi
330 libBiModules lib = (libBuildInfo lib, libModules lib)
331 exeBiModules exe = (buildInfo exe, ModuleName.main : exeModules exe)
332 biModuless = (map libBiModules . maybeToList $ library pd)
333 ++ (map exeBiModules $ executables pd)
334 buildableBiModuless = filter isBuildable biModuless
335 where isBuildable (bi', _) = buildable bi'
336 (bi, modules) = case buildableBiModuless of
337 [] -> error "No buildable component found"
338 [biModules] -> biModules
339 _ -> error ("XXX ghc-cabal can't handle " ++
340 "more than one buildinfo yet")
341 -- XXX Another Just...
342 Just ghcProg = lookupProgram ghcProgram (withPrograms lbi)
343
344 dep_pkgs = PackageIndex.topologicalOrder (packageHacks (installedPkgs lbi))
345 forDeps f = concatMap f dep_pkgs
346
347 -- copied from Distribution.Simple.PreProcess.ppHsc2Hs
348 packageHacks = case compilerFlavor (compiler lbi) of
349 GHC -> hackRtsPackage
350 _ -> id
351 -- We don't link in the actual Haskell libraries of our
352 -- dependencies, so the -u flags in the ldOptions of the rts
353 -- package mean linking fails on OS X (it's ld is a tad
354 -- stricter than gnu ld). Thus we remove the ldOptions for
355 -- GHC's rts package:
356 hackRtsPackage index =
357 case PackageIndex.lookupPackageName index (mkPackageName "rts") of
358 [(_,[rts])] ->
359 PackageIndex.insert rts{
360 Installed.ldOptions = [],
361 Installed.libraryDirs = filter (not . ("gcc-lib" `isSuffixOf`)) (Installed.libraryDirs rts)} index
362 -- GHC <= 6.12 had $topdir/gcc-lib in their
363 -- library-dirs for the rts package, which causes
364 -- problems when we try to use the in-tree mingw,
365 -- due to accidentally picking up the incompatible
366 -- libraries there. So we filter out gcc-lib from
367 -- the RTS's library-dirs here.
368 _ -> error "No (or multiple) ghc rts package is registered!!"
369
370 dep_ids = map snd (externalPackageDeps lbi)
371 deps = map display dep_ids
372 dep_direct = map (fromMaybe (error "ghc-cabal: dep_keys failed")
373 . PackageIndex.lookupUnitId
374 (installedPkgs lbi)
375 . fst)
376 . externalPackageDeps
377 $ lbi
378 dep_ipids = map (display . Installed.installedUnitId) dep_direct
379 depLibNames
380 | packageKeySupported comp = dep_ipids
381 | otherwise = deps
382 depNames = map (display . packageName) dep_ids
383
384 transitive_dep_ids = map Installed.sourcePackageId dep_pkgs
385 transitiveDeps = map display transitive_dep_ids
386 transitiveDepLibNames
387 | packageKeySupported comp = map fixupRtsLibName transitiveDeps
388 | otherwise = transitiveDeps
389 fixupRtsLibName "rts-1.0" = "rts"
390 fixupRtsLibName x = x
391 transitiveDepNames = map (display . packageName) transitive_dep_ids
392
393 libraryDirs = forDeps Installed.libraryDirs
394 -- The mkLibraryRelDir function is a bit of a hack.
395 -- Ideally it should be handled in the makefiles instead.
396 mkLibraryRelDir "rts" = "rts/dist/build"
397 mkLibraryRelDir "ghc" = "compiler/stage2/build"
398 mkLibraryRelDir "Cabal" = "libraries/Cabal/Cabal/dist-install/build"
399 mkLibraryRelDir l = "libraries/" ++ l ++ "/dist-install/build"
400 libraryRelDirs = map mkLibraryRelDir transitiveDepNames
401 wrappedIncludeDirs <- wrap $ forDeps Installed.includeDirs
402
403 let variablePrefix = directory ++ '_':distdir
404 mods = map display modules
405 otherMods = map display (otherModules bi)
406 allMods = mods ++ otherMods
407 let xs = [variablePrefix ++ "_VERSION = " ++ display (pkgVersion (package pd)),
408 -- TODO: move inside withLibLBI
409 variablePrefix ++ "_COMPONENT_ID = " ++ localCompatPackageKey lbi,
410 variablePrefix ++ "_MODULES = " ++ unwords mods,
411 variablePrefix ++ "_HIDDEN_MODULES = " ++ unwords otherMods,
412 variablePrefix ++ "_SYNOPSIS =" ++ (unwords $ lines $ synopsis pd),
413 variablePrefix ++ "_HS_SRC_DIRS = " ++ unwords (hsSourceDirs bi),
414 variablePrefix ++ "_DEPS = " ++ unwords deps,
415 variablePrefix ++ "_DEP_IPIDS = " ++ unwords dep_ipids,
416 variablePrefix ++ "_DEP_NAMES = " ++ unwords depNames,
417 variablePrefix ++ "_DEP_COMPONENT_IDS = " ++ unwords depLibNames,
418 variablePrefix ++ "_TRANSITIVE_DEP_NAMES = " ++ unwords transitiveDepNames,
419 variablePrefix ++ "_TRANSITIVE_DEP_COMPONENT_IDS = " ++ unwords transitiveDepLibNames,
420 variablePrefix ++ "_INCLUDE_DIRS = " ++ unwords (includeDirs bi),
421 variablePrefix ++ "_INCLUDES = " ++ unwords (includes bi),
422 variablePrefix ++ "_INSTALL_INCLUDES = " ++ unwords (installIncludes bi),
423 variablePrefix ++ "_EXTRA_LIBRARIES = " ++ unwords (extraLibs bi),
424 variablePrefix ++ "_EXTRA_LIBDIRS = " ++ unwords (extraLibDirs bi),
425 variablePrefix ++ "_C_SRCS = " ++ unwords (cSources bi),
426 variablePrefix ++ "_CMM_SRCS := $(addprefix cbits/,$(notdir $(wildcard " ++ directory ++ "/cbits/*.cmm)))",
427 variablePrefix ++ "_DATA_FILES = " ++ unwords (dataFiles pd),
428 -- XXX This includes things it shouldn't, like:
429 -- -odir dist-bootstrapping/build
430 variablePrefix ++ "_HC_OPTS = " ++ escape (unwords
431 ( programDefaultArgs ghcProg
432 ++ hcOptions GHC bi
433 ++ languageToFlags (compiler lbi) (defaultLanguage bi)
434 ++ extensionsToFlags (compiler lbi) (usedExtensions bi)
435 ++ programOverrideArgs ghcProg)),
436 variablePrefix ++ "_CC_OPTS = " ++ unwords (ccOptions bi),
437 variablePrefix ++ "_CPP_OPTS = " ++ unwords (cppOptions bi),
438 variablePrefix ++ "_LD_OPTS = " ++ unwords (ldOptions bi),
439 variablePrefix ++ "_DEP_INCLUDE_DIRS_SINGLE_QUOTED = " ++ unwords wrappedIncludeDirs,
440 variablePrefix ++ "_DEP_CC_OPTS = " ++ unwords (forDeps Installed.ccOptions),
441 variablePrefix ++ "_DEP_LIB_DIRS_SEARCHPATH = " ++ mkSearchPath libraryDirs,
442 variablePrefix ++ "_DEP_LIB_REL_DIRS = " ++ unwords libraryRelDirs,
443 variablePrefix ++ "_DEP_LIB_REL_DIRS_SEARCHPATH = " ++ mkSearchPath libraryRelDirs,
444 variablePrefix ++ "_DEP_LD_OPTS = " ++ unwords (forDeps Installed.ldOptions),
445 variablePrefix ++ "_BUILD_GHCI_LIB = " ++ boolToYesNo (withGHCiLib lbi),
446 "",
447 -- Sometimes we need to modify the automatically-generated package-data.mk
448 -- bindings in a special way for the GHC build system, so allow that here:
449 "$(eval $(" ++ directory ++ "_PACKAGE_MAGIC))"
450 ]
451 writeFile (distdir ++ "/package-data.mk") $ unlines xs
452
453 writeFileUtf8 (distdir ++ "/haddock-prologue.txt") $
454 if null (description pd) then synopsis pd
455 else description pd
456 unless (null dll0Modules) $
457 do let dll0Mods = words dll0Modules
458 dllMods = allMods \\ dll0Mods
459 dllModSets = map unwords [dll0Mods, dllMods]
460 writeFile (distdir ++ "/dll-split") $ unlines dllModSets
461 where
462 escape = foldr (\c xs -> if c == '#' then '\\':'#':xs else c:xs) []
463 wrap = mapM wrap1
464 wrap1 s
465 | null s = die ["Wrapping empty value"]
466 | '\'' `elem` s = die ["Single quote in value to be wrapped:", s]
467 -- We want to be able to assume things like <space><quote> is the
468 -- start of a value, so check there are no spaces in confusing
469 -- positions
470 | head s == ' ' = die ["Leading space in value to be wrapped:", s]
471 | last s == ' ' = die ["Trailing space in value to be wrapped:", s]
472 | otherwise = return ("\'" ++ s ++ "\'")
473 mkSearchPath = intercalate [searchPathSeparator]
474 boolToYesNo True = "YES"
475 boolToYesNo False = "NO"
476
477 -- | Version of 'writeFile' that always uses UTF8 encoding
478 writeFileUtf8 f txt = withFile f WriteMode $ \hdl -> do
479 hSetEncoding hdl utf8
480 hPutStr hdl txt