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 : topdir : directory : distDir
38 : myDestDir : myPrefix : myLibdir : myDocdir
39 : relocatableBuild : args' ->
40 doInstall ghc ghcpkg 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 -> String
145 doInstall ghc ghcpkg 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 progs' = updateProgram ghcProg
224 $ updateProgram ghcPkgProg progs
225 instInfos <- dump verbosity ghcPkgProg GlobalPackageDB
226 let installedPkgs' = PackageIndex.fromList instInfos
227 let mlc = libraryConfig lbi
230 let cipds = componentPackageDeps lc
231 cipds' = [ (fixupPackageId instInfos ipid, pid)
232 | (ipid,pid) <- cipds ]
234 componentPackageDeps = cipds'
238 libraryConfig = mlc',
239 installedPkgs = installedPkgs',
240 installDirTemplates = idts',
241 withPrograms = progs'
245 -- The packages are built with the package ID ending in "-inplace", but
246 -- when they're installed they get the package hash appended. We need to
247 -- fix up the package deps so that they use the hash package IDs, not
248 -- the inplace package IDs.
249 fixupPackageId :: [Installed.InstalledPackageInfo]
250 -> InstalledPackageId
251 -> InstalledPackageId
252 fixupPackageId _ x@(InstalledPackageId ipi)
253 | "builtin_" `isPrefixOf` ipi = x
254 fixupPackageId ipinfos (InstalledPackageId ipi)
255 = case stripPrefix (reverse "-inplace") $ reverse ipi of
257 error ("Installed package ID doesn't end in -inplace: " ++ show ipi)
259 let ipi' = reverse ('-' : x)
260 f (ipinfo : ipinfos') = case Installed.installedPackageId ipinfo of
261 y@(InstalledPackageId ipinfoid)
262 | ipi' `isPrefixOf` ipinfoid ->
266 f [] = error ("Installed package ID not registered: " ++ show ipi)
269 generate :: [String] -> FilePath -> FilePath -> IO ()
270 generate config_args distdir directory
271 = withCurrentDirectory directory
272 $ do let verbosity = normal
273 -- XXX We shouldn't just configure with the default flags
274 -- XXX And this, and thus the "getPersistBuildConfig distdir" below,
275 -- aren't going to work when the deps aren't built yet
276 withArgs (["configure", "--distdir", distdir] ++ config_args)
279 lbi <- getPersistBuildConfig distdir
280 let pd0 = localPkgDescr lbi
283 if (buildType pd0 == Just Configure) || (buildType pd0 == Just Custom)
285 maybe_infoFile <- defaultHookedPackageDesc
286 case maybe_infoFile of
287 Nothing -> return emptyHookedBuildInfo
288 Just infoFile -> readHookedBuildInfo verbosity infoFile
290 return emptyHookedBuildInfo
292 let pd = updatePackageDescription hooked_bi pd0
294 -- generate Paths_<pkg>.hs and cabal-macros.h
295 writeAutogenFiles verbosity pd lbi
297 -- generate inplace-pkg-config
298 case (library pd, libraryConfig lbi) of
299 (Nothing, Nothing) -> return ()
300 (Just lib, Just clbi) -> do
301 cwd <- getCurrentDirectory
302 let ipid = InstalledPackageId (display (packageId pd) ++ "-inplace")
303 let installedPkgInfo = inplaceInstalledPackageInfo cwd distdir
305 final_ipi = installedPkgInfo{ Installed.installedPackageId = ipid }
306 content = Installed.showInstalledPackageInfo final_ipi ++ "\n"
307 writeFileAtomic (distdir </> "inplace-pkg-config") content
308 _ -> error "Inconsistent lib components; can't happen?"
311 libBiModules lib = (libBuildInfo lib, libModules lib)
312 exeBiModules exe = (buildInfo exe, ModuleName.main : exeModules exe)
313 biModuless = (maybeToList $ fmap libBiModules $ library pd)
314 ++ (map exeBiModules $ executables pd)
315 buildableBiModuless = filter isBuildable biModuless
316 where isBuildable (bi', _) = buildable bi'
317 (bi, modules) = case buildableBiModuless of
318 [] -> error "No buildable component found"
319 [biModules] -> biModules
320 _ -> error ("XXX ghc-cabal can't handle " ++
321 "more than one buildinfo yet")
322 -- XXX Another Just...
323 Just ghcProg = lookupProgram ghcProgram (withPrograms lbi)
325 dep_pkgs = PackageIndex.topologicalOrder (packageHacks (installedPkgs lbi))
326 forDeps f = concatMap f dep_pkgs
328 -- copied from Distribution.Simple.PreProcess.ppHsc2Hs
329 packageHacks = case compilerFlavor (compiler lbi) of
330 GHC -> hackRtsPackage
332 -- We don't link in the actual Haskell libraries of our
333 -- dependencies, so the -u flags in the ldOptions of the rts
334 -- package mean linking fails on OS X (it's ld is a tad
335 -- stricter than gnu ld). Thus we remove the ldOptions for
336 -- GHC's rts package:
337 hackRtsPackage index =
338 case PackageIndex.lookupPackageName index (PackageName "rts") of
339 [(_,[rts])] -> PackageIndex.insert rts{ Installed.ldOptions = [] } index
340 _ -> error "No (or multiple) ghc rts package is registered!!"
342 dep_ids = map snd (externalPackageDeps lbi)
344 let variablePrefix = directory ++ '_':distdir
345 let xs = [variablePrefix ++ "_VERSION = " ++ display (pkgVersion (package pd)),
346 variablePrefix ++ "_MODULES = " ++ unwords (map display modules),
347 variablePrefix ++ "_HS_SRC_DIRS = " ++ unwords (hsSourceDirs bi),
348 variablePrefix ++ "_DEPS = " ++ unwords (map display dep_ids),
349 variablePrefix ++ "_DEP_NAMES = " ++ unwords (map (display . packageName) dep_ids),
350 variablePrefix ++ "_INCLUDE_DIRS = " ++ unwords (includeDirs bi),
351 variablePrefix ++ "_INCLUDES = " ++ unwords (includes bi),
352 variablePrefix ++ "_INSTALL_INCLUDES = " ++ unwords (installIncludes bi),
353 variablePrefix ++ "_EXTRA_LIBRARIES = " ++ unwords (extraLibs bi),
354 variablePrefix ++ "_EXTRA_LIBDIRS = " ++ unwords (extraLibDirs bi),
355 variablePrefix ++ "_C_SRCS = " ++ unwords (cSources bi),
356 variablePrefix ++ "_CMM_SRCS = $(addprefix cbits/,$(notdir $(wildcard " ++ directory ++ "/cbits/*.cmm)))",
357 -- XXX This includes things it shouldn't, like:
358 -- -odir dist-bootstrapping/build
359 variablePrefix ++ "_HC_OPTS = " ++ escape (unwords
362 ++ extensionsToFlags (compiler lbi) (extensions bi))),
363 variablePrefix ++ "_CC_OPTS = " ++ unwords (ccOptions bi),
364 variablePrefix ++ "_CPP_OPTS = " ++ unwords (cppOptions bi),
365 variablePrefix ++ "_LD_OPTS = " ++ unwords (ldOptions bi),
366 variablePrefix ++ "_DEP_INCLUDE_DIRS = " ++ unwords (wrap $ forDeps Installed.includeDirs),
367 variablePrefix ++ "_DEP_CC_OPTS = " ++ unwords (forDeps Installed.ccOptions),
368 variablePrefix ++ "_DEP_LIB_DIRS = " ++ unwords (wrap $ forDeps Installed.libraryDirs),
369 variablePrefix ++ "_DEP_EXTRA_LIBS = " ++ unwords (forDeps Installed.extraLibraries),
370 variablePrefix ++ "_DEP_LD_OPTS = " ++ unwords (forDeps Installed.ldOptions)]
371 writeFile (distdir ++ "/package-data.mk") $ unlines xs
373 escape = foldr (\c xs -> if c == '#' then '\\':'#':xs else c:xs) []
374 wrap = map (\s -> "\'" ++ s ++ "\'")