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