2 module Main (main) where
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.Simple
10 import Distribution.Simple.Configure
11 import Distribution.Simple.LocalBuildInfo
12 import Distribution.Simple.Program
13 import Distribution.Simple.Program.HcPkg
14 import Distribution.Simple.Utils (defaultPackageDesc, writeFileAtomic, toUTF8)
15 import Distribution.Simple.Build (writeAutogenFiles)
16 import Distribution.Simple.Register
17 import Distribution.Text
18 import Distribution.Verbosity
19 import qualified Distribution.InstalledPackageInfo as Installed
20 import qualified Distribution.Simple.PackageIndex as PackageIndex
25 import System.Directory
26 import System.Environment
28 import System.FilePath
31 main = do args <- getArgs
33 "hscolour" : distDir : dir : args' ->
34 runHsColour distDir dir args'
37 "install" : ghc : ghcpkg : strip : topdir : directory : distDir
38 : myDestDir : myPrefix : myLibdir : myDocdir
39 : relocatableBuild : args' ->
40 doInstall ghc ghcpkg strip topdir directory distDir
41 myDestDir myPrefix myLibdir myDocdir
42 relocatableBuild args'
43 "configure" : args' -> case break (== "--") args' of
44 (config_args, "--" : distdir : directories) ->
45 mapM_ (generate config_args distdir) directories
47 "sdist" : dir : distDir : [] ->
50 defaultMainArgs ["--version"]
53 syntax_error :: [String]
55 ["syntax: ghc-cabal configure <configure-args> -- <distdir> <directory>...",
56 " ghc-cabal install <ghc-pkg> <directory> <distdir> <destdir> <prefix> <args>...",
57 " ghc-cabal hscolour <distdir> <directory> <args>..."]
59 die :: [String] -> IO a
60 die errs = do mapM_ (hPutStrLn stderr) errs
61 exitWith (ExitFailure 1)
63 -- XXX Should use bracket
64 withCurrentDirectory :: FilePath -> IO a -> IO a
65 withCurrentDirectory directory io
66 = do curDirectory <- getCurrentDirectory
67 setCurrentDirectory directory
69 setCurrentDirectory curDirectory
72 -- We need to use the autoconfUserHooks, as the packages that use
73 -- configure can create a .buildinfo file, and we need any info that
75 userHooks :: UserHooks
76 userHooks = autoconfUserHooks
78 runDefaultMain :: IO ()
80 = do let verbosity = normal
81 gpdFile <- defaultPackageDesc verbosity
82 gpd <- readPackageDescription verbosity gpdFile
83 case buildType (flattenPackageDescription gpd) of
84 Just Configure -> defaultMainWithHooks autoconfUserHooks
85 -- time has a "Custom" Setup.hs, but it's actually Configure
86 -- plus a "./Setup test" hook. However, Cabal is also
87 -- "Custom", but doesn't have a configure script.
89 do configureExists <- doesFileExist "configure"
91 then defaultMainWithHooks autoconfUserHooks
93 -- not quite right, but good enough for us:
96 doSdist :: FilePath -> FilePath -> IO ()
97 doSdist directory distDir
98 = withCurrentDirectory directory
99 $ withArgs (["sdist", "--builddir", distDir])
102 doCheck :: FilePath -> IO ()
104 = withCurrentDirectory directory
105 $ do let verbosity = normal
106 gpdFile <- defaultPackageDesc verbosity
107 gpd <- readPackageDescription verbosity gpdFile
108 case partition isFailure $ checkPackage gpd Nothing of
109 ([], []) -> return ()
110 ([], warnings) -> mapM_ print warnings
111 (errs, _) -> do mapM_ print errs
112 exitWith (ExitFailure 1)
113 where isFailure (PackageDistSuspicious {}) = False
116 runHsColour :: FilePath -> FilePath -> [String] -> IO ()
117 runHsColour distdir directory args
118 = withCurrentDirectory directory
119 $ defaultMainArgs ("hscolour" : "--builddir" : distdir : args)
121 doInstall :: FilePath -> FilePath -> FilePath -> FilePath -> FilePath
122 -> FilePath -> FilePath -> FilePath -> FilePath -> FilePath
123 -> String -> [String]
125 doInstall ghc ghcpkg strip topdir directory distDir
126 myDestDir myPrefix myLibdir myDocdir
127 relocatableBuildStr args
128 = withCurrentDirectory directory $ do
129 relocatableBuild <- case relocatableBuildStr of
132 _ -> die ["Bad relocatableBuildStr: " ++
133 show relocatableBuildStr]
134 let copyArgs = ["copy", "--builddir", distDir]
135 ++ (if null myDestDir
137 else ["--destdir", myDestDir])
139 regArgs = "register" : "--builddir" : distDir : args
140 copyHooks = userHooks {
141 copyHook = noGhcPrimHook
145 regHooks = userHooks {
146 regHook = modHook relocatableBuild
150 defaultMainWithHooksArgs copyHooks copyArgs
151 defaultMainWithHooksArgs regHooks regArgs
153 noGhcPrimHook f pd lbi us flags
155 | packageName pd == PackageName "ghc-prim" =
158 let ghcPrim = fromJust (simpleParse "GHC.Prim")
159 ems = filter (ghcPrim /=) (exposedModules lib)
160 lib' = lib { exposedModules = ems }
161 in pd { library = Just lib' }
163 error "Expected a library, but none found"
165 in f pd' lbi us flags
166 modHook relocatableBuild f pd lbi us flags
167 = do let verbosity = normal
168 idts = installDirTemplates lbi
170 prefix = toPathTemplate $
174 libdir = toPathTemplate $
178 libsubdir = toPathTemplate "$pkgid",
179 docdir = toPathTemplate $
181 then "$topdir/../doc/html/libraries/$pkgid"
182 else (myDocdir </> "$pkgid"),
183 htmldir = toPathTemplate "$docdir"
185 progs = withPrograms lbi
186 ghcProg = ConfiguredProgram {
187 programId = programName ghcProgram,
188 programVersion = Nothing,
189 programDefaultArgs = ["-B" ++ topdir],
190 programOverrideArgs = [],
191 programLocation = UserSpecified ghc
193 ghcpkgconf = topdir </> "package.conf.d"
194 ghcPkgProg = ConfiguredProgram {
195 programId = programName ghcPkgProgram,
196 programVersion = Nothing,
197 programDefaultArgs = ["--global-conf",
199 ++ if not (null myDestDir)
202 programOverrideArgs = [],
203 programLocation = UserSpecified ghcpkg
205 stripProg = ConfiguredProgram {
206 programId = programName stripProgram,
207 programVersion = Nothing,
208 programDefaultArgs = [],
209 programOverrideArgs = [],
210 programLocation = UserSpecified strip
212 progs' = updateProgram ghcProg
213 $ updateProgram ghcPkgProg
214 $ updateProgram stripProg
216 instInfos <- dump verbosity ghcPkgProg GlobalPackageDB
217 let installedPkgs' = PackageIndex.fromList instInfos
218 let mlc = libraryConfig lbi
221 let cipds = componentPackageDeps lc
222 cipds' = [ (fixupPackageId instInfos ipid, pid)
223 | (ipid,pid) <- cipds ]
225 componentPackageDeps = cipds'
229 libraryConfig = mlc',
230 installedPkgs = installedPkgs',
231 installDirTemplates = idts',
232 withPrograms = progs'
236 -- The packages are built with the package ID ending in "-inplace", but
237 -- when they're installed they get the package hash appended. We need to
238 -- fix up the package deps so that they use the hash package IDs, not
239 -- the inplace package IDs.
240 fixupPackageId :: [Installed.InstalledPackageInfo]
241 -> InstalledPackageId
242 -> InstalledPackageId
243 fixupPackageId _ x@(InstalledPackageId ipi)
244 | "builtin_" `isPrefixOf` ipi = x
245 fixupPackageId ipinfos (InstalledPackageId ipi)
246 = case stripPrefix (reverse "-inplace") $ reverse ipi of
248 error ("Installed package ID doesn't end in -inplace: " ++ show ipi)
250 let ipi' = reverse ('-' : x)
251 f (ipinfo : ipinfos') = case Installed.installedPackageId ipinfo of
252 y@(InstalledPackageId ipinfoid)
253 | ipi' `isPrefixOf` ipinfoid ->
257 f [] = error ("Installed package ID not registered: " ++ show ipi)
260 generate :: [String] -> FilePath -> FilePath -> IO ()
261 generate config_args distdir directory
262 = withCurrentDirectory directory
263 $ do let verbosity = normal
264 -- XXX We shouldn't just configure with the default flags
265 -- XXX And this, and thus the "getPersistBuildConfig distdir" below,
266 -- aren't going to work when the deps aren't built yet
267 withArgs (["configure", "--distdir", distdir] ++ config_args)
270 lbi <- getPersistBuildConfig distdir
271 let pd0 = localPkgDescr lbi
274 if (buildType pd0 == Just Configure) || (buildType pd0 == Just Custom)
276 maybe_infoFile <- defaultHookedPackageDesc
277 case maybe_infoFile of
278 Nothing -> return emptyHookedBuildInfo
279 Just infoFile -> readHookedBuildInfo verbosity infoFile
281 return emptyHookedBuildInfo
283 let pd = updatePackageDescription hooked_bi pd0
285 -- generate Paths_<pkg>.hs and cabal-macros.h
286 writeAutogenFiles verbosity pd lbi
288 -- generate inplace-pkg-config
289 case (library pd, libraryConfig lbi) of
290 (Nothing, Nothing) -> return ()
291 (Just lib, Just clbi) -> do
292 cwd <- getCurrentDirectory
293 let ipid = InstalledPackageId (display (packageId pd) ++ "-inplace")
294 let installedPkgInfo = inplaceInstalledPackageInfo cwd distdir
296 final_ipi = installedPkgInfo {
297 Installed.installedPackageId = ipid,
298 Installed.haddockHTMLs = ["../" ++ display (packageId pd)]
300 content = Installed.showInstalledPackageInfo final_ipi ++ "\n"
301 writeFileAtomic (distdir </> "inplace-pkg-config") (toUTF8 content)
302 _ -> error "Inconsistent lib components; can't happen?"
305 libBiModules lib = (libBuildInfo lib, libModules lib)
306 exeBiModules exe = (buildInfo exe, ModuleName.main : exeModules exe)
307 biModuless = (maybeToList $ fmap libBiModules $ library pd)
308 ++ (map exeBiModules $ executables pd)
309 buildableBiModuless = filter isBuildable biModuless
310 where isBuildable (bi', _) = buildable bi'
311 (bi, modules) = case buildableBiModuless of
312 [] -> error "No buildable component found"
313 [biModules] -> biModules
314 _ -> error ("XXX ghc-cabal can't handle " ++
315 "more than one buildinfo yet")
316 -- XXX Another Just...
317 Just ghcProg = lookupProgram ghcProgram (withPrograms lbi)
319 dep_pkgs = PackageIndex.topologicalOrder (packageHacks (installedPkgs lbi))
320 forDeps f = concatMap f dep_pkgs
322 -- copied from Distribution.Simple.PreProcess.ppHsc2Hs
323 packageHacks = case compilerFlavor (compiler lbi) of
324 GHC -> hackRtsPackage
326 -- We don't link in the actual Haskell libraries of our
327 -- dependencies, so the -u flags in the ldOptions of the rts
328 -- package mean linking fails on OS X (it's ld is a tad
329 -- stricter than gnu ld). Thus we remove the ldOptions for
330 -- GHC's rts package:
331 hackRtsPackage index =
332 case PackageIndex.lookupPackageName index (PackageName "rts") of
334 PackageIndex.insert rts{
335 Installed.ldOptions = [],
336 Installed.libraryDirs = filter (not . ("gcc-lib" `isSuffixOf`)) (Installed.libraryDirs rts)} index
337 -- GHC <= 6.12 had $topdir/gcc-lib in their
338 -- library-dirs for the rts package, which causes
339 -- problems when we try to use the in-tree mingw,
340 -- due to accidentally picking up the incompatible
341 -- libraries there. So we filter out gcc-lib from
342 -- the RTS's library-dirs here.
343 _ -> error "No (or multiple) ghc rts package is registered!!"
345 dep_ids = map snd (externalPackageDeps lbi)
347 let variablePrefix = directory ++ '_':distdir
348 let xs = [variablePrefix ++ "_VERSION = " ++ display (pkgVersion (package pd)),
349 variablePrefix ++ "_MODULES = " ++ unwords (map display modules),
350 variablePrefix ++ "_HIDDEN_MODULES = " ++ unwords (map display (otherModules bi)),
351 variablePrefix ++ "_SYNOPSIS =" ++ synopsis pd,
352 variablePrefix ++ "_HS_SRC_DIRS = " ++ unwords (hsSourceDirs bi),
353 variablePrefix ++ "_DEPS = " ++ unwords (map display dep_ids),
354 variablePrefix ++ "_DEP_NAMES = " ++ unwords (map (display . packageName) dep_ids),
355 variablePrefix ++ "_INCLUDE_DIRS = " ++ unwords (includeDirs bi),
356 variablePrefix ++ "_INCLUDES = " ++ unwords (includes bi),
357 variablePrefix ++ "_INSTALL_INCLUDES = " ++ unwords (installIncludes bi),
358 variablePrefix ++ "_EXTRA_LIBRARIES = " ++ unwords (extraLibs bi),
359 variablePrefix ++ "_EXTRA_LIBDIRS = " ++ unwords (extraLibDirs bi),
360 variablePrefix ++ "_C_SRCS = " ++ unwords (cSources bi),
361 variablePrefix ++ "_CMM_SRCS := $(addprefix cbits/,$(notdir $(wildcard " ++ directory ++ "/cbits/*.cmm)))",
362 variablePrefix ++ "_DATA_FILES = " ++ unwords (dataFiles pd),
363 -- XXX This includes things it shouldn't, like:
364 -- -odir dist-bootstrapping/build
365 variablePrefix ++ "_HC_OPTS = " ++ escape (unwords
366 ( programDefaultArgs ghcProg
368 ++ languageToFlags (compiler lbi) (defaultLanguage bi)
369 ++ extensionsToFlags (compiler lbi) (usedExtensions bi)
370 ++ programOverrideArgs ghcProg)),
371 variablePrefix ++ "_CC_OPTS = " ++ unwords (ccOptions bi),
372 variablePrefix ++ "_CPP_OPTS = " ++ unwords (cppOptions bi),
373 variablePrefix ++ "_LD_OPTS = " ++ unwords (ldOptions bi),
374 variablePrefix ++ "_DEP_INCLUDE_DIRS = " ++ unwords (wrap $ forDeps Installed.includeDirs),
375 variablePrefix ++ "_DEP_CC_OPTS = " ++ unwords (forDeps Installed.ccOptions),
376 variablePrefix ++ "_DEP_LIB_DIRS = " ++ unwords (wrap $ forDeps Installed.libraryDirs),
377 variablePrefix ++ "_DEP_EXTRA_LIBS = " ++ unwords (forDeps Installed.extraLibraries),
378 variablePrefix ++ "_DEP_LD_OPTS = " ++ unwords (forDeps Installed.ldOptions),
379 variablePrefix ++ "_BUILD_GHCI_LIB = " ++ boolToYesNo (withGHCiLib lbi),
381 -- Sometimes we need to modify the automatically-generated package-data.mk
382 -- bindings in a special way for the GHC build system, so allow that here:
383 "$(eval $(" ++ directory ++ "_PACKAGE_MAGIC))"
385 writeFile (distdir ++ "/package-data.mk") $ unlines xs
386 writeFile (distdir ++ "/haddock-prologue.txt") $
387 if null (description pd) then synopsis pd
390 escape = foldr (\c xs -> if c == '#' then '\\':'#':xs else c:xs) []
391 wrap = map (\s -> "\'" ++ s ++ "\'")
392 boolToYesNo True = "YES"
393 boolToYesNo False = "NO"