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 hSetBuffering stdout LineBuffering
34 "hscolour" : distDir : dir : args' ->
35 runHsColour distDir dir args'
38 "install" : ghc : ghcpkg : strip : topdir : directory : distDir
39 : myDestDir : myPrefix : myLibdir : myDocdir
40 : relocatableBuild : args' ->
41 doInstall ghc ghcpkg strip topdir directory distDir
42 myDestDir myPrefix myLibdir myDocdir
43 relocatableBuild args'
44 "configure" : args' -> case break (== "--") args' of
45 (config_args, "--" : distdir : directories) ->
46 mapM_ (generate config_args distdir) directories
48 "sdist" : dir : distDir : [] ->
51 defaultMainArgs ["--version"]
54 syntax_error :: [String]
56 ["syntax: ghc-cabal configure <configure-args> -- <distdir> <directory>...",
57 " ghc-cabal install <ghc-pkg> <directory> <distdir> <destdir> <prefix> <args>...",
58 " ghc-cabal hscolour <distdir> <directory> <args>..."]
60 die :: [String] -> IO a
61 die errs = do mapM_ (hPutStrLn stderr) errs
62 exitWith (ExitFailure 1)
64 -- XXX Should use bracket
65 withCurrentDirectory :: FilePath -> IO a -> IO a
66 withCurrentDirectory directory io
67 = do curDirectory <- getCurrentDirectory
68 setCurrentDirectory directory
70 setCurrentDirectory curDirectory
73 -- We need to use the autoconfUserHooks, as the packages that use
74 -- configure can create a .buildinfo file, and we need any info that
76 userHooks :: UserHooks
77 userHooks = autoconfUserHooks
79 runDefaultMain :: IO ()
81 = do let verbosity = normal
82 gpdFile <- defaultPackageDesc verbosity
83 gpd <- readPackageDescription verbosity gpdFile
84 case buildType (flattenPackageDescription gpd) of
85 Just Configure -> defaultMainWithHooks autoconfUserHooks
86 -- time has a "Custom" Setup.hs, but it's actually Configure
87 -- plus a "./Setup test" hook. However, Cabal is also
88 -- "Custom", but doesn't have a configure script.
90 do configureExists <- doesFileExist "configure"
92 then defaultMainWithHooks autoconfUserHooks
94 -- not quite right, but good enough for us:
97 doSdist :: FilePath -> FilePath -> IO ()
98 doSdist directory distDir
99 = withCurrentDirectory directory
100 $ withArgs (["sdist", "--builddir", distDir])
103 doCheck :: FilePath -> IO ()
105 = withCurrentDirectory directory
106 $ do let verbosity = normal
107 gpdFile <- defaultPackageDesc verbosity
108 gpd <- readPackageDescription verbosity gpdFile
109 case partition isFailure $ checkPackage gpd Nothing of
110 ([], []) -> return ()
111 ([], warnings) -> mapM_ print warnings
112 (errs, _) -> do mapM_ print errs
113 exitWith (ExitFailure 1)
114 where isFailure (PackageDistSuspicious {}) = False
117 runHsColour :: FilePath -> FilePath -> [String] -> IO ()
118 runHsColour distdir directory args
119 = withCurrentDirectory directory
120 $ defaultMainArgs ("hscolour" : "--builddir" : distdir : args)
122 doInstall :: FilePath -> FilePath -> FilePath -> FilePath -> FilePath
123 -> FilePath -> FilePath -> FilePath -> FilePath -> FilePath
124 -> String -> [String]
126 doInstall ghc ghcpkg strip topdir directory distDir
127 myDestDir myPrefix myLibdir myDocdir
128 relocatableBuildStr args
129 = withCurrentDirectory directory $ do
130 relocatableBuild <- case relocatableBuildStr of
133 _ -> die ["Bad relocatableBuildStr: " ++
134 show relocatableBuildStr]
135 let copyArgs = ["copy", "--builddir", distDir]
136 ++ (if null myDestDir
138 else ["--destdir", myDestDir])
140 regArgs = "register" : "--builddir" : distDir : args
141 copyHooks = userHooks {
142 copyHook = noGhcPrimHook
146 regHooks = userHooks {
147 regHook = modHook relocatableBuild
151 defaultMainWithHooksArgs copyHooks copyArgs
152 defaultMainWithHooksArgs regHooks regArgs
154 noGhcPrimHook f pd lbi us flags
156 | packageName pd == PackageName "ghc-prim" =
159 let ghcPrim = fromJust (simpleParse "GHC.Prim")
160 ems = filter (ghcPrim /=) (exposedModules lib)
161 lib' = lib { exposedModules = ems }
162 in pd { library = Just lib' }
164 error "Expected a library, but none found"
166 in f pd' lbi us flags
167 modHook relocatableBuild f pd lbi us flags
168 = do let verbosity = normal
169 idts = installDirTemplates lbi
171 prefix = toPathTemplate $
175 libdir = toPathTemplate $
179 libsubdir = toPathTemplate "$pkgid",
180 docdir = toPathTemplate $
182 then "$topdir/../doc/html/libraries/$pkgid"
183 else (myDocdir </> "$pkgid"),
184 htmldir = toPathTemplate "$docdir"
186 progs = withPrograms lbi
187 ghcProg = ConfiguredProgram {
188 programId = programName ghcProgram,
189 programVersion = Nothing,
190 programDefaultArgs = ["-B" ++ topdir],
191 programOverrideArgs = [],
192 programLocation = UserSpecified ghc
194 ghcpkgconf = topdir </> "package.conf.d"
195 ghcPkgProg = ConfiguredProgram {
196 programId = programName ghcPkgProgram,
197 programVersion = Nothing,
198 programDefaultArgs = ["--global-conf",
200 ++ if not (null myDestDir)
203 programOverrideArgs = [],
204 programLocation = UserSpecified ghcpkg
206 stripProg = ConfiguredProgram {
207 programId = programName stripProgram,
208 programVersion = Nothing,
209 programDefaultArgs = [],
210 programOverrideArgs = [],
211 programLocation = UserSpecified strip
213 progs' = updateProgram ghcProg
214 $ updateProgram ghcPkgProg
215 $ updateProgram stripProg
217 instInfos <- dump verbosity ghcPkgProg GlobalPackageDB
218 let installedPkgs' = PackageIndex.fromList instInfos
219 let mlc = libraryConfig lbi
222 let cipds = componentPackageDeps lc
223 cipds' = [ (fixupPackageId instInfos ipid, pid)
224 | (ipid,pid) <- cipds ]
226 componentPackageDeps = cipds'
230 libraryConfig = mlc',
231 installedPkgs = installedPkgs',
232 installDirTemplates = idts',
233 withPrograms = progs'
237 -- The packages are built with the package ID ending in "-inplace", but
238 -- when they're installed they get the package hash appended. We need to
239 -- fix up the package deps so that they use the hash package IDs, not
240 -- the inplace package IDs.
241 fixupPackageId :: [Installed.InstalledPackageInfo]
242 -> InstalledPackageId
243 -> InstalledPackageId
244 fixupPackageId _ x@(InstalledPackageId ipi)
245 | "builtin_" `isPrefixOf` ipi = x
246 fixupPackageId ipinfos (InstalledPackageId ipi)
247 = case stripPrefix (reverse "-inplace") $ reverse ipi of
249 error ("Installed package ID doesn't end in -inplace: " ++ show ipi)
251 let ipi' = reverse ('-' : x)
252 f (ipinfo : ipinfos') = case Installed.installedPackageId ipinfo of
253 y@(InstalledPackageId ipinfoid)
254 | ipi' `isPrefixOf` ipinfoid ->
258 f [] = error ("Installed package ID not registered: " ++ show ipi)
261 generate :: [String] -> FilePath -> FilePath -> IO ()
262 generate config_args distdir directory
263 = withCurrentDirectory directory
264 $ do let verbosity = normal
265 -- XXX We shouldn't just configure with the default flags
266 -- XXX And this, and thus the "getPersistBuildConfig distdir" below,
267 -- aren't going to work when the deps aren't built yet
268 withArgs (["configure", "--distdir", distdir] ++ config_args)
271 lbi <- getPersistBuildConfig distdir
272 let pd0 = localPkgDescr lbi
275 if (buildType pd0 == Just Configure) || (buildType pd0 == Just Custom)
277 maybe_infoFile <- defaultHookedPackageDesc
278 case maybe_infoFile of
279 Nothing -> return emptyHookedBuildInfo
280 Just infoFile -> readHookedBuildInfo verbosity infoFile
282 return emptyHookedBuildInfo
284 let pd = updatePackageDescription hooked_bi pd0
286 -- generate Paths_<pkg>.hs and cabal-macros.h
287 writeAutogenFiles verbosity pd lbi
289 -- generate inplace-pkg-config
290 case (library pd, libraryConfig lbi) of
291 (Nothing, Nothing) -> return ()
292 (Just lib, Just clbi) -> do
293 cwd <- getCurrentDirectory
294 let ipid = InstalledPackageId (display (packageId pd) ++ "-inplace")
295 let installedPkgInfo = inplaceInstalledPackageInfo cwd distdir
297 final_ipi = installedPkgInfo {
298 Installed.installedPackageId = ipid,
299 Installed.haddockHTMLs = []
301 content = Installed.showInstalledPackageInfo final_ipi ++ "\n"
302 writeFileAtomic (distdir </> "inplace-pkg-config") (toUTF8 content)
303 _ -> error "Inconsistent lib components; can't happen?"
306 libBiModules lib = (libBuildInfo lib, libModules lib)
307 exeBiModules exe = (buildInfo exe, ModuleName.main : exeModules exe)
308 biModuless = (maybeToList $ fmap libBiModules $ library pd)
309 ++ (map exeBiModules $ executables pd)
310 buildableBiModuless = filter isBuildable biModuless
311 where isBuildable (bi', _) = buildable bi'
312 (bi, modules) = case buildableBiModuless of
313 [] -> error "No buildable component found"
314 [biModules] -> biModules
315 _ -> error ("XXX ghc-cabal can't handle " ++
316 "more than one buildinfo yet")
317 -- XXX Another Just...
318 Just ghcProg = lookupProgram ghcProgram (withPrograms lbi)
320 dep_pkgs = PackageIndex.topologicalOrder (packageHacks (installedPkgs lbi))
321 forDeps f = concatMap f dep_pkgs
323 -- copied from Distribution.Simple.PreProcess.ppHsc2Hs
324 packageHacks = case compilerFlavor (compiler lbi) of
325 GHC -> hackRtsPackage
327 -- We don't link in the actual Haskell libraries of our
328 -- dependencies, so the -u flags in the ldOptions of the rts
329 -- package mean linking fails on OS X (it's ld is a tad
330 -- stricter than gnu ld). Thus we remove the ldOptions for
331 -- GHC's rts package:
332 hackRtsPackage index =
333 case PackageIndex.lookupPackageName index (PackageName "rts") of
335 PackageIndex.insert rts{
336 Installed.ldOptions = [],
337 Installed.libraryDirs = filter (not . ("gcc-lib" `isSuffixOf`)) (Installed.libraryDirs rts)} index
338 -- GHC <= 6.12 had $topdir/gcc-lib in their
339 -- library-dirs for the rts package, which causes
340 -- problems when we try to use the in-tree mingw,
341 -- due to accidentally picking up the incompatible
342 -- libraries there. So we filter out gcc-lib from
343 -- the RTS's library-dirs here.
344 _ -> error "No (or multiple) ghc rts package is registered!!"
346 dep_ids = map snd (externalPackageDeps lbi)
348 wrappedIncludeDirs <- wrap $ forDeps Installed.includeDirs
349 wrappedLibraryDirs <- wrap $ forDeps Installed.libraryDirs
351 let variablePrefix = directory ++ '_':distdir
352 let xs = [variablePrefix ++ "_VERSION = " ++ display (pkgVersion (package pd)),
353 variablePrefix ++ "_MODULES = " ++ unwords (map display modules),
354 variablePrefix ++ "_HIDDEN_MODULES = " ++ unwords (map display (otherModules bi)),
355 variablePrefix ++ "_SYNOPSIS =" ++ synopsis pd,
356 variablePrefix ++ "_HS_SRC_DIRS = " ++ unwords (hsSourceDirs bi),
357 variablePrefix ++ "_DEPS = " ++ unwords (map display dep_ids),
358 variablePrefix ++ "_DEP_NAMES = " ++ unwords (map (display . packageName) dep_ids),
359 variablePrefix ++ "_INCLUDE_DIRS = " ++ unwords (includeDirs bi),
360 variablePrefix ++ "_INCLUDES = " ++ unwords (includes bi),
361 variablePrefix ++ "_INSTALL_INCLUDES = " ++ unwords (installIncludes bi),
362 variablePrefix ++ "_EXTRA_LIBRARIES = " ++ unwords (extraLibs bi),
363 variablePrefix ++ "_EXTRA_LIBDIRS = " ++ unwords (extraLibDirs bi),
364 variablePrefix ++ "_C_SRCS = " ++ unwords (cSources bi),
365 variablePrefix ++ "_CMM_SRCS := $(addprefix cbits/,$(notdir $(wildcard " ++ directory ++ "/cbits/*.cmm)))",
366 variablePrefix ++ "_DATA_FILES = " ++ unwords (dataFiles pd),
367 -- XXX This includes things it shouldn't, like:
368 -- -odir dist-bootstrapping/build
369 variablePrefix ++ "_HC_OPTS = " ++ escape (unwords
370 ( programDefaultArgs ghcProg
372 ++ languageToFlags (compiler lbi) (defaultLanguage bi)
373 ++ extensionsToFlags (compiler lbi) (usedExtensions bi)
374 ++ programOverrideArgs ghcProg)),
375 variablePrefix ++ "_CC_OPTS = " ++ unwords (ccOptions bi),
376 variablePrefix ++ "_CPP_OPTS = " ++ unwords (cppOptions bi),
377 variablePrefix ++ "_LD_OPTS = " ++ unwords (ldOptions bi),
378 variablePrefix ++ "_DEP_INCLUDE_DIRS_SINGLE_QUOTED = " ++ unwords wrappedIncludeDirs,
379 variablePrefix ++ "_DEP_CC_OPTS = " ++ unwords (forDeps Installed.ccOptions),
380 variablePrefix ++ "_DEP_LIB_DIRS_SINGLE_QUOTED = " ++ unwords wrappedLibraryDirs,
381 variablePrefix ++ "_DEP_EXTRA_LIBS = " ++ unwords (forDeps Installed.extraLibraries),
382 variablePrefix ++ "_DEP_LD_OPTS = " ++ unwords (forDeps Installed.ldOptions),
383 variablePrefix ++ "_BUILD_GHCI_LIB = " ++ boolToYesNo (withGHCiLib lbi),
385 -- Sometimes we need to modify the automatically-generated package-data.mk
386 -- bindings in a special way for the GHC build system, so allow that here:
387 "$(eval $(" ++ directory ++ "_PACKAGE_MAGIC))"
389 writeFile (distdir ++ "/package-data.mk") $ unlines xs
390 writeFile (distdir ++ "/haddock-prologue.txt") $
391 if null (description pd) then synopsis pd
394 escape = foldr (\c xs -> if c == '#' then '\\':'#':xs else c:xs) []
397 | null s = die ["Wrapping empty value"]
398 | '\'' `elem` s = die ["Single quote in value to be wrapped:", s]
399 -- We want to be able to assume things like <space><quote> is the
400 -- start of a value, so check there are no spaces in confusing
402 | head s == ' ' = die ["Leading space in value to be wrapped:", s]
403 | last s == ' ' = die ["Trailing space in value to be wrapped:", s]
404 | otherwise = return ("\'" ++ s ++ "\'")
405 boolToYesNo True = "YES"
406 boolToYesNo False = "NO"