d33652fe960e091845bd7d6081545472cc48ad3b
[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 "$pkgid",
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 libBiModules lib = (libBuildInfo lib, libModules lib)
360 exeBiModules exe = (buildInfo exe, ModuleName.main : exeModules exe)
361 biModuless = (maybeToList $ fmap libBiModules $ library pd)
362 ++ (map exeBiModules $ executables pd)
363 buildableBiModuless = filter isBuildable biModuless
364 where isBuildable (bi', _) = buildable bi'
365 (bi, modules) = case buildableBiModuless of
366 [] -> error "No buildable component found"
367 [biModules] -> biModules
368 _ -> error ("XXX ghc-cabal can't handle " ++
369 "more than one buildinfo yet")
370 -- XXX Another Just...
371 Just ghcProg = lookupProgram ghcProgram (withPrograms lbi)
372
373 dep_pkgs = PackageIndex.topologicalOrder (packageHacks (installedPkgs lbi))
374 forDeps f = concatMap f dep_pkgs
375
376 -- copied from Distribution.Simple.PreProcess.ppHsc2Hs
377 packageHacks = case compilerFlavor (compiler lbi) of
378 GHC -> hackRtsPackage
379 _ -> id
380 -- We don't link in the actual Haskell libraries of our
381 -- dependencies, so the -u flags in the ldOptions of the rts
382 -- package mean linking fails on OS X (it's ld is a tad
383 -- stricter than gnu ld). Thus we remove the ldOptions for
384 -- GHC's rts package:
385 hackRtsPackage index =
386 case PackageIndex.lookupPackageName index (PackageName "rts") of
387 [(_,[rts])] ->
388 PackageIndex.insert rts{
389 Installed.ldOptions = [],
390 Installed.libraryDirs = filter (not . ("gcc-lib" `isSuffixOf`)) (Installed.libraryDirs rts)} index
391 -- GHC <= 6.12 had $topdir/gcc-lib in their
392 -- library-dirs for the rts package, which causes
393 -- problems when we try to use the in-tree mingw,
394 -- due to accidentally picking up the incompatible
395 -- libraries there. So we filter out gcc-lib from
396 -- the RTS's library-dirs here.
397 _ -> error "No (or multiple) ghc rts package is registered!!"
398
399 dep_ids = map snd (externalPackageDeps lbi)
400 deps = map display dep_ids
401 depNames = map (display . packageName) dep_ids
402
403 transitive_dep_ids = map Installed.sourcePackageId dep_pkgs
404 transitiveDeps = map display transitive_dep_ids
405 transitiveDepNames = map (display . packageName) transitive_dep_ids
406
407 libraryDirs = forDeps Installed.libraryDirs
408 -- The mkLibraryRelDir function is a bit of a hack.
409 -- Ideally it should be handled in the makefiles instead.
410 mkLibraryRelDir "rts" = "rts/dist/build"
411 mkLibraryRelDir "ghc" = "compiler/stage2/build"
412 mkLibraryRelDir "Cabal" = "libraries/Cabal/Cabal/dist-install/build"
413 mkLibraryRelDir l = "libraries/" ++ l ++ "/dist-install/build"
414 libraryRelDirs = map mkLibraryRelDir transitiveDepNames
415 wrappedIncludeDirs <- wrap $ forDeps Installed.includeDirs
416 wrappedLibraryDirs <- wrap libraryDirs
417
418 let variablePrefix = directory ++ '_':distdir
419 mods = map display modules
420 otherMods = map display (otherModules bi)
421 allMods = mods ++ otherMods
422 let xs = [variablePrefix ++ "_VERSION = " ++ display (pkgVersion (package pd)),
423 variablePrefix ++ "_MODULES = " ++ unwords mods,
424 variablePrefix ++ "_HIDDEN_MODULES = " ++ unwords otherMods,
425 variablePrefix ++ "_SYNOPSIS =" ++ synopsis pd,
426 variablePrefix ++ "_HS_SRC_DIRS = " ++ unwords (hsSourceDirs bi),
427 variablePrefix ++ "_DEPS = " ++ unwords deps,
428 variablePrefix ++ "_DEP_NAMES = " ++ unwords depNames,
429 variablePrefix ++ "_TRANSITIVE_DEPS = " ++ unwords transitiveDeps,
430 variablePrefix ++ "_TRANSITIVE_DEP_NAMES = " ++ unwords transitiveDepNames,
431 variablePrefix ++ "_INCLUDE_DIRS = " ++ unwords (includeDirs bi),
432 variablePrefix ++ "_INCLUDES = " ++ unwords (includes bi),
433 variablePrefix ++ "_INSTALL_INCLUDES = " ++ unwords (installIncludes bi),
434 variablePrefix ++ "_EXTRA_LIBRARIES = " ++ unwords (extraLibs bi),
435 variablePrefix ++ "_EXTRA_LIBDIRS = " ++ unwords (extraLibDirs bi),
436 variablePrefix ++ "_C_SRCS = " ++ unwords (cSources bi),
437 variablePrefix ++ "_CMM_SRCS := $(addprefix cbits/,$(notdir $(wildcard " ++ directory ++ "/cbits/*.cmm)))",
438 variablePrefix ++ "_DATA_FILES = " ++ unwords (dataFiles pd),
439 -- XXX This includes things it shouldn't, like:
440 -- -odir dist-bootstrapping/build
441 variablePrefix ++ "_HC_OPTS = " ++ escape (unwords
442 ( programDefaultArgs ghcProg
443 ++ hcOptions GHC bi
444 ++ languageToFlags (compiler lbi) (defaultLanguage bi)
445 ++ extensionsToFlags (compiler lbi) (usedExtensions bi)
446 ++ programOverrideArgs ghcProg)),
447 variablePrefix ++ "_CC_OPTS = " ++ unwords (ccOptions bi),
448 variablePrefix ++ "_CPP_OPTS = " ++ unwords (cppOptions bi),
449 variablePrefix ++ "_LD_OPTS = " ++ unwords (ldOptions bi),
450 variablePrefix ++ "_DEP_INCLUDE_DIRS_SINGLE_QUOTED = " ++ unwords wrappedIncludeDirs,
451 variablePrefix ++ "_DEP_CC_OPTS = " ++ unwords (forDeps Installed.ccOptions),
452 variablePrefix ++ "_DEP_LIB_DIRS_SINGLE_QUOTED = " ++ unwords wrappedLibraryDirs,
453 variablePrefix ++ "_DEP_LIB_DIRS_SEARCHPATH = " ++ mkSearchPath libraryDirs,
454 variablePrefix ++ "_DEP_LIB_REL_DIRS = " ++ unwords libraryRelDirs,
455 variablePrefix ++ "_DEP_LIB_REL_DIRS_SEARCHPATH = " ++ mkSearchPath libraryRelDirs,
456 variablePrefix ++ "_DEP_EXTRA_LIBS = " ++ unwords (forDeps Installed.extraLibraries),
457 variablePrefix ++ "_DEP_LD_OPTS = " ++ unwords (forDeps Installed.ldOptions),
458 variablePrefix ++ "_BUILD_GHCI_LIB = " ++ boolToYesNo (withGHCiLib lbi),
459 "",
460 -- Sometimes we need to modify the automatically-generated package-data.mk
461 -- bindings in a special way for the GHC build system, so allow that here:
462 "$(eval $(" ++ directory ++ "_PACKAGE_MAGIC))"
463 ]
464 writeFile (distdir ++ "/package-data.mk") $ unlines xs
465
466 writeFileUtf8 (distdir ++ "/haddock-prologue.txt") $
467 if null (description pd) then synopsis pd
468 else description pd
469 unless (null dll0Modules) $
470 do let dll0Mods = words dll0Modules
471 dllMods = allMods \\ dll0Mods
472 dllModSets = map unwords [dll0Mods, dllMods]
473 writeFile (distdir ++ "/dll-split") $ unlines dllModSets
474 where
475 escape = foldr (\c xs -> if c == '#' then '\\':'#':xs else c:xs) []
476 wrap = mapM wrap1
477 wrap1 s
478 | null s = die ["Wrapping empty value"]
479 | '\'' `elem` s = die ["Single quote in value to be wrapped:", s]
480 -- We want to be able to assume things like <space><quote> is the
481 -- start of a value, so check there are no spaces in confusing
482 -- positions
483 | head s == ' ' = die ["Leading space in value to be wrapped:", s]
484 | last s == ' ' = die ["Trailing space in value to be wrapped:", s]
485 | otherwise = return ("\'" ++ s ++ "\'")
486 mkSearchPath = intercalate [searchPathSeparator]
487 boolToYesNo True = "YES"
488 boolToYesNo False = "NO"
489
490 -- | Version of 'writeFile' that always uses UTF8 encoding
491 writeFileUtf8 f txt = withFile f WriteMode $ \hdl -> do
492 hSetEncoding hdl utf8
493 hPutStr hdl txt