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 $
202 else (myDocdir </> "$pkg"),
203 htmldir = toPathTemplate "$docdir"
205 progs = withPrograms lbi
206 ghcProg = ConfiguredProgram {
207 programId = programName ghcProgram,
208 programVersion = Nothing,
209 programArgs = ["-B" ++ topdir],
210 programLocation = UserSpecified ghc
212 ghcpkgconf = topdir </> "package.conf.d"
213 ghcPkgProg = ConfiguredProgram {
214 programId = programName ghcPkgProgram,
215 programVersion = Nothing,
216 programArgs = ["--global-conf",
218 ++ if not (null myDestDir)
221 programLocation = UserSpecified ghcpkg
223 stripProg = ConfiguredProgram {
224 programId = programName stripProgram,
225 programVersion = Nothing,
227 programLocation = UserSpecified strip
229 progs' = updateProgram ghcProg
230 $ updateProgram ghcPkgProg
231 $ updateProgram stripProg
233 instInfos <- dump verbosity ghcPkgProg GlobalPackageDB
234 let installedPkgs' = PackageIndex.fromList instInfos
235 let mlc = libraryConfig lbi
238 let cipds = componentPackageDeps lc
239 cipds' = [ (fixupPackageId instInfos ipid, pid)
240 | (ipid,pid) <- cipds ]
242 componentPackageDeps = cipds'
246 libraryConfig = mlc',
247 installedPkgs = installedPkgs',
248 installDirTemplates = idts',
249 withPrograms = progs'
253 -- The packages are built with the package ID ending in "-inplace", but
254 -- when they're installed they get the package hash appended. We need to
255 -- fix up the package deps so that they use the hash package IDs, not
256 -- the inplace package IDs.
257 fixupPackageId :: [Installed.InstalledPackageInfo]
258 -> InstalledPackageId
259 -> InstalledPackageId
260 fixupPackageId _ x@(InstalledPackageId ipi)
261 | "builtin_" `isPrefixOf` ipi = x
262 fixupPackageId ipinfos (InstalledPackageId ipi)
263 = case stripPrefix (reverse "-inplace") $ reverse ipi of
265 error ("Installed package ID doesn't end in -inplace: " ++ show ipi)
267 let ipi' = reverse ('-' : x)
268 f (ipinfo : ipinfos') = case Installed.installedPackageId ipinfo of
269 y@(InstalledPackageId ipinfoid)
270 | ipi' `isPrefixOf` ipinfoid ->
274 f [] = error ("Installed package ID not registered: " ++ show ipi)
277 generate :: [String] -> FilePath -> FilePath -> IO ()
278 generate config_args distdir directory
279 = withCurrentDirectory directory
280 $ do let verbosity = normal
281 -- XXX We shouldn't just configure with the default flags
282 -- XXX And this, and thus the "getPersistBuildConfig distdir" below,
283 -- aren't going to work when the deps aren't built yet
284 withArgs (["configure", "--distdir", distdir] ++ config_args)
287 lbi <- getPersistBuildConfig distdir
288 let pd0 = localPkgDescr lbi
291 if (buildType pd0 == Just Configure) || (buildType pd0 == Just Custom)
293 maybe_infoFile <- defaultHookedPackageDesc
294 case maybe_infoFile of
295 Nothing -> return emptyHookedBuildInfo
296 Just infoFile -> readHookedBuildInfo verbosity infoFile
298 return emptyHookedBuildInfo
300 let pd = updatePackageDescription hooked_bi pd0
302 -- generate Paths_<pkg>.hs and cabal-macros.h
303 writeAutogenFiles verbosity pd lbi
305 -- generate inplace-pkg-config
306 case (library pd, libraryConfig lbi) of
307 (Nothing, Nothing) -> return ()
308 (Just lib, Just clbi) -> do
309 cwd <- getCurrentDirectory
310 let ipid = InstalledPackageId (display (packageId pd) ++ "-inplace")
311 let installedPkgInfo = inplaceInstalledPackageInfo cwd distdir
313 final_ipi = installedPkgInfo{ Installed.installedPackageId = ipid }
314 content = Installed.showInstalledPackageInfo final_ipi ++ "\n"
315 writeFileAtomic (distdir </> "inplace-pkg-config") content
316 _ -> error "Inconsistent lib components; can't happen?"
319 libBiModules lib = (libBuildInfo lib, libModules lib)
320 exeBiModules exe = (buildInfo exe, ModuleName.main : exeModules exe)
321 biModuless = (maybeToList $ fmap libBiModules $ library pd)
322 ++ (map exeBiModules $ executables pd)
323 buildableBiModuless = filter isBuildable biModuless
324 where isBuildable (bi', _) = buildable bi'
325 (bi, modules) = case buildableBiModuless of
326 [] -> error "No buildable component found"
327 [biModules] -> biModules
328 _ -> error ("XXX ghc-cabal can't handle " ++
329 "more than one buildinfo yet")
330 -- XXX Another Just...
331 Just ghcProg = lookupProgram ghcProgram (withPrograms lbi)
333 dep_pkgs = PackageIndex.topologicalOrder (packageHacks (installedPkgs lbi))
334 forDeps f = concatMap f dep_pkgs
336 -- copied from Distribution.Simple.PreProcess.ppHsc2Hs
337 packageHacks = case compilerFlavor (compiler lbi) of
338 GHC -> hackRtsPackage
340 -- We don't link in the actual Haskell libraries of our
341 -- dependencies, so the -u flags in the ldOptions of the rts
342 -- package mean linking fails on OS X (it's ld is a tad
343 -- stricter than gnu ld). Thus we remove the ldOptions for
344 -- GHC's rts package:
345 hackRtsPackage index =
346 case PackageIndex.lookupPackageName index (PackageName "rts") of
347 [(_,[rts])] -> PackageIndex.insert rts{ Installed.ldOptions = [] } index
348 _ -> error "No (or multiple) ghc rts package is registered!!"
350 dep_ids = map snd (externalPackageDeps lbi)
352 let variablePrefix = directory ++ '_':distdir
353 let xs = [variablePrefix ++ "_VERSION = " ++ display (pkgVersion (package pd)),
354 variablePrefix ++ "_MODULES = " ++ unwords (map display modules),
355 variablePrefix ++ "_HS_SRC_DIRS = " ++ unwords (hsSourceDirs bi),
356 variablePrefix ++ "_DEPS = " ++ unwords (map display dep_ids),
357 variablePrefix ++ "_DEP_NAMES = " ++ unwords (map (display . packageName) dep_ids),
358 variablePrefix ++ "_INCLUDE_DIRS = " ++ unwords (includeDirs bi),
359 variablePrefix ++ "_INCLUDES = " ++ unwords (includes bi),
360 variablePrefix ++ "_INSTALL_INCLUDES = " ++ unwords (installIncludes bi),
361 variablePrefix ++ "_EXTRA_LIBRARIES = " ++ unwords (extraLibs bi),
362 variablePrefix ++ "_EXTRA_LIBDIRS = " ++ unwords (extraLibDirs bi),
363 variablePrefix ++ "_C_SRCS = " ++ unwords (cSources bi),
364 variablePrefix ++ "_CMM_SRCS = $(addprefix cbits/,$(notdir $(wildcard " ++ directory ++ "/cbits/*.cmm)))",
365 -- XXX This includes things it shouldn't, like:
366 -- -odir dist-bootstrapping/build
367 variablePrefix ++ "_HC_OPTS = " ++ escape (unwords
370 ++ extensionsToFlags (compiler lbi) (extensions bi))),
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 writeFile (distdir ++ "/package-data.mk") $ unlines xs
381 escape = foldr (\c xs -> if c == '#' then '\\':'#':xs else c:xs) []
382 wrap = map (\s -> "\'" ++ s ++ "\'")