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)
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 "haddock" : distDir : dir : args' ->
34 runHaddock 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 : [] ->
51 syntax_error :: [String]
53 ["syntax: ghc-cabal configure <configure-args> -- <distdir> <directory>...",
54 " ghc-cabal install <ghc-pkg> <directory> <distdir> <destdir> <prefix> <args>...",
55 " ghc-cabal haddock <distdir> <directory> <args>..."]
57 die :: [String] -> IO a
58 die errs = do mapM_ (hPutStrLn stderr) errs
59 exitWith (ExitFailure 1)
61 -- XXX Should use bracket
62 withCurrentDirectory :: FilePath -> IO a -> IO a
63 withCurrentDirectory directory io
64 = do curDirectory <- getCurrentDirectory
65 setCurrentDirectory directory
67 setCurrentDirectory curDirectory
70 -- We need to use the autoconfUserHooks, as the packages that use
71 -- configure can create a .buildinfo file, and we need any info that
73 userHooks :: UserHooks
74 userHooks = autoconfUserHooks
76 runDefaultMain :: IO ()
78 = do let verbosity = normal
79 gpdFile <- defaultPackageDesc verbosity
80 gpd <- readPackageDescription verbosity gpdFile
81 case buildType (flattenPackageDescription gpd) of
82 Just Configure -> defaultMainWithHooks autoconfUserHooks
83 -- time has a "Custom" Setup.hs, but it's actually Configure
84 -- plus a "./Setup test" hook. However, Cabal is also
85 -- "Custom", but doesn't have a configure script.
87 do configureExists <- doesFileExist "configure"
89 then defaultMainWithHooks autoconfUserHooks
91 -- not quite right, but good enough for us:
94 doSdist :: FilePath -> FilePath -> IO ()
95 doSdist directory distDir
96 = withCurrentDirectory directory
97 $ withArgs (["sdist", "--builddir", distDir])
100 doCheck :: FilePath -> IO ()
102 = withCurrentDirectory directory
103 $ do let verbosity = normal
104 gpdFile <- defaultPackageDesc verbosity
105 gpd <- readPackageDescription verbosity gpdFile
106 case partition isFailure $ checkPackage gpd Nothing of
107 ([], []) -> return ()
108 ([], warnings) -> mapM_ print warnings
109 (errs, _) -> do mapM_ print errs
110 exitWith (ExitFailure 1)
111 where isFailure (PackageDistSuspicious {}) = False
114 runHaddock :: FilePath -> FilePath -> [String] -> IO ()
115 runHaddock distdir directory args
116 = withCurrentDirectory directory
117 $ defaultMainWithHooksArgs hooks ("haddock" : "--builddir" : distdir : args)
120 haddockHook = modHook (haddockHook userHooks)
122 modHook f pd lbi us flags
123 | packageName pd == PackageName "ghc-prim"
124 = let pd' = case library pd of
126 let ghcPrim = fromJust (simpleParse "GHC.Prim")
127 ems = filter (ghcPrim /=)
129 lib' = lib { exposedModules = ems }
130 in pd { library = Just lib' }
132 error "Expected a library, but none found"
133 pc = withPrograms lbi
134 pc' = userSpecifyArgs "haddock"
135 ["dist-install/build/autogen/GHC/Prim.hs"] pc
136 lbi' = lbi { withPrograms = pc' }
137 in f pd' lbi' us flags
141 doInstall :: FilePath -> FilePath -> FilePath -> FilePath -> FilePath
142 -> FilePath -> FilePath -> FilePath -> FilePath -> FilePath
143 -> String -> [String]
145 doInstall ghc ghcpkg strip topdir directory distDir
146 myDestDir myPrefix myLibdir myDocdir
147 relocatableBuildStr args
148 = withCurrentDirectory directory $ do
149 relocatableBuild <- case relocatableBuildStr of
152 _ -> die ["Bad relocatableBuildStr: " ++
153 show relocatableBuildStr]
154 let copyArgs = ["copy", "--builddir", distDir]
155 ++ (if null myDestDir
157 else ["--destdir", myDestDir])
159 regArgs = "register" : "--builddir" : distDir : args
160 copyHooks = userHooks {
161 copyHook = noGhcPrimHook
165 regHooks = userHooks {
166 regHook = modHook relocatableBuild
170 defaultMainWithHooksArgs copyHooks copyArgs
171 defaultMainWithHooksArgs regHooks regArgs
173 noGhcPrimHook f pd lbi us flags
175 | packageName pd == PackageName "ghc-prim" =
178 let ghcPrim = fromJust (simpleParse "GHC.Prim")
179 ems = filter (ghcPrim /=) (exposedModules lib)
180 lib' = lib { exposedModules = ems }
181 in pd { library = Just lib' }
183 error "Expected a library, but none found"
185 in f pd' lbi us flags
186 modHook relocatableBuild f pd lbi us flags
187 = do let verbosity = normal
188 idts = installDirTemplates lbi
190 prefix = toPathTemplate $
194 libdir = toPathTemplate $
198 libsubdir = toPathTemplate "$pkgid",
199 docdir = toPathTemplate $
201 then "$topdir/$pkgid"
202 else (myDocdir </> "$pkgid"),
203 htmldir = toPathTemplate "$docdir"
205 progs = withPrograms lbi
206 ghcProg = ConfiguredProgram {
207 programId = programName ghcProgram,
208 programVersion = Nothing,
209 programDefaultArgs = ["-B" ++ topdir],
210 programOverrideArgs = [],
211 programLocation = UserSpecified ghc
213 ghcpkgconf = topdir </> "package.conf.d"
214 ghcPkgProg = ConfiguredProgram {
215 programId = programName ghcPkgProgram,
216 programVersion = Nothing,
217 programDefaultArgs = ["--global-conf",
219 ++ if not (null myDestDir)
222 programOverrideArgs = [],
223 programLocation = UserSpecified ghcpkg
225 stripProg = ConfiguredProgram {
226 programId = programName stripProgram,
227 programVersion = Nothing,
228 programDefaultArgs = [],
229 programOverrideArgs = [],
230 programLocation = UserSpecified strip
232 progs' = updateProgram ghcProg
233 $ updateProgram ghcPkgProg
234 $ updateProgram stripProg
236 instInfos <- dump verbosity ghcPkgProg GlobalPackageDB
237 let installedPkgs' = PackageIndex.fromList instInfos
238 let mlc = libraryConfig lbi
241 let cipds = componentPackageDeps lc
242 cipds' = [ (fixupPackageId instInfos ipid, pid)
243 | (ipid,pid) <- cipds ]
245 componentPackageDeps = cipds'
249 libraryConfig = mlc',
250 installedPkgs = installedPkgs',
251 installDirTemplates = idts',
252 withPrograms = progs'
256 -- The packages are built with the package ID ending in "-inplace", but
257 -- when they're installed they get the package hash appended. We need to
258 -- fix up the package deps so that they use the hash package IDs, not
259 -- the inplace package IDs.
260 fixupPackageId :: [Installed.InstalledPackageInfo]
261 -> InstalledPackageId
262 -> InstalledPackageId
263 fixupPackageId _ x@(InstalledPackageId ipi)
264 | "builtin_" `isPrefixOf` ipi = x
265 fixupPackageId ipinfos (InstalledPackageId ipi)
266 = case stripPrefix (reverse "-inplace") $ reverse ipi of
268 error ("Installed package ID doesn't end in -inplace: " ++ show ipi)
270 let ipi' = reverse ('-' : x)
271 f (ipinfo : ipinfos') = case Installed.installedPackageId ipinfo of
272 y@(InstalledPackageId ipinfoid)
273 | ipi' `isPrefixOf` ipinfoid ->
277 f [] = error ("Installed package ID not registered: " ++ show ipi)
280 generate :: [String] -> FilePath -> FilePath -> IO ()
281 generate config_args distdir directory
282 = withCurrentDirectory directory
283 $ do let verbosity = normal
284 -- XXX We shouldn't just configure with the default flags
285 -- XXX And this, and thus the "getPersistBuildConfig distdir" below,
286 -- aren't going to work when the deps aren't built yet
287 withArgs (["configure", "--distdir", distdir] ++ config_args)
290 lbi <- getPersistBuildConfig distdir
291 let pd0 = localPkgDescr lbi
294 if (buildType pd0 == Just Configure) || (buildType pd0 == Just Custom)
296 maybe_infoFile <- defaultHookedPackageDesc
297 case maybe_infoFile of
298 Nothing -> return emptyHookedBuildInfo
299 Just infoFile -> readHookedBuildInfo verbosity infoFile
301 return emptyHookedBuildInfo
303 let pd = updatePackageDescription hooked_bi pd0
305 -- generate Paths_<pkg>.hs and cabal-macros.h
306 writeAutogenFiles verbosity pd lbi
308 -- generate inplace-pkg-config
309 case (library pd, libraryConfig lbi) of
310 (Nothing, Nothing) -> return ()
311 (Just lib, Just clbi) -> do
312 cwd <- getCurrentDirectory
313 let ipid = InstalledPackageId (display (packageId pd) ++ "-inplace")
314 let installedPkgInfo = inplaceInstalledPackageInfo cwd distdir
316 final_ipi = installedPkgInfo {
317 Installed.installedPackageId = ipid,
318 Installed.haddockHTMLs = ["../" ++ display (packageId pd)]
320 content = Installed.showInstalledPackageInfo final_ipi ++ "\n"
321 writeFileAtomic (distdir </> "inplace-pkg-config") content
322 _ -> error "Inconsistent lib components; can't happen?"
325 libBiModules lib = (libBuildInfo lib, libModules lib)
326 exeBiModules exe = (buildInfo exe, ModuleName.main : exeModules exe)
327 biModuless = (maybeToList $ fmap libBiModules $ library pd)
328 ++ (map exeBiModules $ executables pd)
329 buildableBiModuless = filter isBuildable biModuless
330 where isBuildable (bi', _) = buildable bi'
331 (bi, modules) = case buildableBiModuless of
332 [] -> error "No buildable component found"
333 [biModules] -> biModules
334 _ -> error ("XXX ghc-cabal can't handle " ++
335 "more than one buildinfo yet")
336 -- XXX Another Just...
337 Just ghcProg = lookupProgram ghcProgram (withPrograms lbi)
339 dep_pkgs = PackageIndex.topologicalOrder (packageHacks (installedPkgs lbi))
340 forDeps f = concatMap f dep_pkgs
342 -- copied from Distribution.Simple.PreProcess.ppHsc2Hs
343 packageHacks = case compilerFlavor (compiler lbi) of
344 GHC -> hackRtsPackage
346 -- We don't link in the actual Haskell libraries of our
347 -- dependencies, so the -u flags in the ldOptions of the rts
348 -- package mean linking fails on OS X (it's ld is a tad
349 -- stricter than gnu ld). Thus we remove the ldOptions for
350 -- GHC's rts package:
351 hackRtsPackage index =
352 case PackageIndex.lookupPackageName index (PackageName "rts") of
353 [(_,[rts])] -> PackageIndex.insert rts{ Installed.ldOptions = [] } index
354 _ -> error "No (or multiple) ghc rts package is registered!!"
356 dep_ids = map snd (externalPackageDeps lbi)
358 let variablePrefix = directory ++ '_':distdir
359 let xs = [variablePrefix ++ "_VERSION = " ++ display (pkgVersion (package pd)),
360 variablePrefix ++ "_MODULES = " ++ unwords (map display modules),
361 variablePrefix ++ "_HS_SRC_DIRS = " ++ unwords (hsSourceDirs bi),
362 variablePrefix ++ "_DEPS = " ++ unwords (map display dep_ids),
363 variablePrefix ++ "_DEP_NAMES = " ++ unwords (map (display . packageName) dep_ids),
364 variablePrefix ++ "_INCLUDE_DIRS = " ++ unwords (includeDirs bi),
365 variablePrefix ++ "_INCLUDES = " ++ unwords (includes bi),
366 variablePrefix ++ "_INSTALL_INCLUDES = " ++ unwords (installIncludes bi),
367 variablePrefix ++ "_EXTRA_LIBRARIES = " ++ unwords (extraLibs bi),
368 variablePrefix ++ "_EXTRA_LIBDIRS = " ++ unwords (extraLibDirs bi),
369 variablePrefix ++ "_C_SRCS = " ++ unwords (cSources bi),
370 variablePrefix ++ "_CMM_SRCS = $(addprefix cbits/,$(notdir $(wildcard " ++ directory ++ "/cbits/*.cmm)))",
371 -- XXX This includes things it shouldn't, like:
372 -- -odir dist-bootstrapping/build
373 variablePrefix ++ "_HC_OPTS = " ++ escape (unwords
374 ( programDefaultArgs ghcProg
376 ++ extensionsToFlags (compiler lbi) (extensions bi)
377 ++ programOverrideArgs ghcProg)),
378 variablePrefix ++ "_CC_OPTS = " ++ unwords (ccOptions bi),
379 variablePrefix ++ "_CPP_OPTS = " ++ unwords (cppOptions bi),
380 variablePrefix ++ "_LD_OPTS = " ++ unwords (ldOptions bi),
381 variablePrefix ++ "_DEP_INCLUDE_DIRS = " ++ unwords (wrap $ forDeps Installed.includeDirs),
382 variablePrefix ++ "_DEP_CC_OPTS = " ++ unwords (forDeps Installed.ccOptions),
383 variablePrefix ++ "_DEP_LIB_DIRS = " ++ unwords (wrap $ forDeps Installed.libraryDirs),
384 variablePrefix ++ "_DEP_EXTRA_LIBS = " ++ unwords (forDeps Installed.extraLibraries),
385 variablePrefix ++ "_DEP_LD_OPTS = " ++ unwords (forDeps Installed.ldOptions)]
386 writeFile (distdir ++ "/package-data.mk") $ unlines xs
388 escape = foldr (\c xs -> if c == '#' then '\\':'#':xs else c:xs) []
389 wrap = map (\s -> "\'" ++ s ++ "\'")