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