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 "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 : [] ->
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 hscolour <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 runHsColour :: FilePath -> FilePath -> [String] -> IO ()
115 runHsColour distdir directory args
116 = withCurrentDirectory directory
117 $ defaultMainArgs ("hscolour" : "--builddir" : distdir : args)
119 doInstall :: FilePath -> FilePath -> FilePath -> FilePath -> FilePath
120 -> FilePath -> FilePath -> FilePath -> FilePath -> FilePath
121 -> String -> [String]
123 doInstall ghc ghcpkg strip topdir directory distDir
124 myDestDir myPrefix myLibdir myDocdir
125 relocatableBuildStr args
126 = withCurrentDirectory directory $ do
127 relocatableBuild <- case relocatableBuildStr of
130 _ -> die ["Bad relocatableBuildStr: " ++
131 show relocatableBuildStr]
132 let copyArgs = ["copy", "--builddir", distDir]
133 ++ (if null myDestDir
135 else ["--destdir", myDestDir])
137 regArgs = "register" : "--builddir" : distDir : args
138 copyHooks = userHooks {
139 copyHook = noGhcPrimHook
143 regHooks = userHooks {
144 regHook = modHook relocatableBuild
148 defaultMainWithHooksArgs copyHooks copyArgs
149 defaultMainWithHooksArgs regHooks regArgs
151 noGhcPrimHook f pd lbi us flags
153 | packageName pd == PackageName "ghc-prim" =
156 let ghcPrim = fromJust (simpleParse "GHC.Prim")
157 ems = filter (ghcPrim /=) (exposedModules lib)
158 lib' = lib { exposedModules = ems }
159 in pd { library = Just lib' }
161 error "Expected a library, but none found"
163 in f pd' lbi us flags
164 modHook relocatableBuild f pd lbi us flags
165 = do let verbosity = normal
166 idts = installDirTemplates lbi
168 prefix = toPathTemplate $
172 libdir = toPathTemplate $
176 libsubdir = toPathTemplate "$pkgid",
177 docdir = toPathTemplate $
179 then "$topdir/$pkgid"
180 else (myDocdir </> "$pkgid"),
181 htmldir = toPathTemplate "$docdir"
183 progs = withPrograms lbi
184 ghcProg = ConfiguredProgram {
185 programId = programName ghcProgram,
186 programVersion = Nothing,
187 programDefaultArgs = ["-B" ++ topdir],
188 programOverrideArgs = [],
189 programLocation = UserSpecified ghc
191 ghcpkgconf = topdir </> "package.conf.d"
192 ghcPkgProg = ConfiguredProgram {
193 programId = programName ghcPkgProgram,
194 programVersion = Nothing,
195 programDefaultArgs = ["--global-conf",
197 ++ if not (null myDestDir)
200 programOverrideArgs = [],
201 programLocation = UserSpecified ghcpkg
203 stripProg = ConfiguredProgram {
204 programId = programName stripProgram,
205 programVersion = Nothing,
206 programDefaultArgs = [],
207 programOverrideArgs = [],
208 programLocation = UserSpecified strip
210 progs' = updateProgram ghcProg
211 $ updateProgram ghcPkgProg
212 $ updateProgram stripProg
214 instInfos <- dump verbosity ghcPkgProg GlobalPackageDB
215 let installedPkgs' = PackageIndex.fromList instInfos
216 let mlc = libraryConfig lbi
219 let cipds = componentPackageDeps lc
220 cipds' = [ (fixupPackageId instInfos ipid, pid)
221 | (ipid,pid) <- cipds ]
223 componentPackageDeps = cipds'
227 libraryConfig = mlc',
228 installedPkgs = installedPkgs',
229 installDirTemplates = idts',
230 withPrograms = progs'
234 -- The packages are built with the package ID ending in "-inplace", but
235 -- when they're installed they get the package hash appended. We need to
236 -- fix up the package deps so that they use the hash package IDs, not
237 -- the inplace package IDs.
238 fixupPackageId :: [Installed.InstalledPackageInfo]
239 -> InstalledPackageId
240 -> InstalledPackageId
241 fixupPackageId _ x@(InstalledPackageId ipi)
242 | "builtin_" `isPrefixOf` ipi = x
243 fixupPackageId ipinfos (InstalledPackageId ipi)
244 = case stripPrefix (reverse "-inplace") $ reverse ipi of
246 error ("Installed package ID doesn't end in -inplace: " ++ show ipi)
248 let ipi' = reverse ('-' : x)
249 f (ipinfo : ipinfos') = case Installed.installedPackageId ipinfo of
250 y@(InstalledPackageId ipinfoid)
251 | ipi' `isPrefixOf` ipinfoid ->
255 f [] = error ("Installed package ID not registered: " ++ show ipi)
258 generate :: [String] -> FilePath -> FilePath -> IO ()
259 generate config_args distdir directory
260 = withCurrentDirectory directory
261 $ do let verbosity = normal
262 -- XXX We shouldn't just configure with the default flags
263 -- XXX And this, and thus the "getPersistBuildConfig distdir" below,
264 -- aren't going to work when the deps aren't built yet
265 withArgs (["configure", "--distdir", distdir] ++ config_args)
268 lbi <- getPersistBuildConfig distdir
269 let pd0 = localPkgDescr lbi
272 if (buildType pd0 == Just Configure) || (buildType pd0 == Just Custom)
274 maybe_infoFile <- defaultHookedPackageDesc
275 case maybe_infoFile of
276 Nothing -> return emptyHookedBuildInfo
277 Just infoFile -> readHookedBuildInfo verbosity infoFile
279 return emptyHookedBuildInfo
281 let pd = updatePackageDescription hooked_bi pd0
283 -- generate Paths_<pkg>.hs and cabal-macros.h
284 writeAutogenFiles verbosity pd lbi
286 -- generate inplace-pkg-config
287 case (library pd, libraryConfig lbi) of
288 (Nothing, Nothing) -> return ()
289 (Just lib, Just clbi) -> do
290 cwd <- getCurrentDirectory
291 let ipid = InstalledPackageId (display (packageId pd) ++ "-inplace")
292 let installedPkgInfo = inplaceInstalledPackageInfo cwd distdir
294 final_ipi = installedPkgInfo {
295 Installed.installedPackageId = ipid,
296 Installed.haddockHTMLs = ["../" ++ display (packageId pd)]
298 content = Installed.showInstalledPackageInfo final_ipi ++ "\n"
299 writeFileAtomic (distdir </> "inplace-pkg-config") content
300 _ -> error "Inconsistent lib components; can't happen?"
303 libBiModules lib = (libBuildInfo lib, libModules lib)
304 exeBiModules exe = (buildInfo exe, ModuleName.main : exeModules exe)
305 biModuless = (maybeToList $ fmap libBiModules $ library pd)
306 ++ (map exeBiModules $ executables pd)
307 buildableBiModuless = filter isBuildable biModuless
308 where isBuildable (bi', _) = buildable bi'
309 (bi, modules) = case buildableBiModuless of
310 [] -> error "No buildable component found"
311 [biModules] -> biModules
312 _ -> error ("XXX ghc-cabal can't handle " ++
313 "more than one buildinfo yet")
314 -- XXX Another Just...
315 Just ghcProg = lookupProgram ghcProgram (withPrograms lbi)
317 dep_pkgs = PackageIndex.topologicalOrder (packageHacks (installedPkgs lbi))
318 forDeps f = concatMap f dep_pkgs
320 -- copied from Distribution.Simple.PreProcess.ppHsc2Hs
321 packageHacks = case compilerFlavor (compiler lbi) of
322 GHC -> hackRtsPackage
324 -- We don't link in the actual Haskell libraries of our
325 -- dependencies, so the -u flags in the ldOptions of the rts
326 -- package mean linking fails on OS X (it's ld is a tad
327 -- stricter than gnu ld). Thus we remove the ldOptions for
328 -- GHC's rts package:
329 hackRtsPackage index =
330 case PackageIndex.lookupPackageName index (PackageName "rts") of
331 [(_,[rts])] -> PackageIndex.insert rts{ Installed.ldOptions = [] } index
332 _ -> error "No (or multiple) ghc rts package is registered!!"
334 dep_ids = map snd (externalPackageDeps lbi)
336 let variablePrefix = directory ++ '_':distdir
337 let xs = [variablePrefix ++ "_VERSION = " ++ display (pkgVersion (package pd)),
338 variablePrefix ++ "_MODULES = " ++ unwords (map display modules),
339 variablePrefix ++ "_HIDDEN_MODULES = " ++ unwords (map display (otherModules bi)),
340 variablePrefix ++ "_SYNOPSIS =" ++ synopsis pd,
341 variablePrefix ++ "_HS_SRC_DIRS = " ++ unwords (hsSourceDirs bi),
342 variablePrefix ++ "_DEPS = " ++ unwords (map display dep_ids),
343 variablePrefix ++ "_DEP_NAMES = " ++ unwords (map (display . packageName) dep_ids),
344 variablePrefix ++ "_INCLUDE_DIRS = " ++ unwords (includeDirs bi),
345 variablePrefix ++ "_INCLUDES = " ++ unwords (includes bi),
346 variablePrefix ++ "_INSTALL_INCLUDES = " ++ unwords (installIncludes bi),
347 variablePrefix ++ "_EXTRA_LIBRARIES = " ++ unwords (extraLibs bi),
348 variablePrefix ++ "_EXTRA_LIBDIRS = " ++ unwords (extraLibDirs bi),
349 variablePrefix ++ "_C_SRCS = " ++ unwords (cSources bi),
350 variablePrefix ++ "_CMM_SRCS = $(addprefix cbits/,$(notdir $(wildcard " ++ directory ++ "/cbits/*.cmm)))",
351 -- XXX This includes things it shouldn't, like:
352 -- -odir dist-bootstrapping/build
353 variablePrefix ++ "_HC_OPTS = " ++ escape (unwords
354 ( programDefaultArgs ghcProg
356 ++ extensionsToFlags (compiler lbi) (extensions bi)
357 ++ programOverrideArgs ghcProg)),
358 variablePrefix ++ "_CC_OPTS = " ++ unwords (ccOptions bi),
359 variablePrefix ++ "_CPP_OPTS = " ++ unwords (cppOptions bi),
360 variablePrefix ++ "_LD_OPTS = " ++ unwords (ldOptions bi),
361 variablePrefix ++ "_DEP_INCLUDE_DIRS = " ++ unwords (wrap $ forDeps Installed.includeDirs),
362 variablePrefix ++ "_DEP_CC_OPTS = " ++ unwords (forDeps Installed.ccOptions),
363 variablePrefix ++ "_DEP_LIB_DIRS = " ++ unwords (wrap $ forDeps Installed.libraryDirs),
364 variablePrefix ++ "_DEP_EXTRA_LIBS = " ++ unwords (forDeps Installed.extraLibraries),
365 variablePrefix ++ "_DEP_LD_OPTS = " ++ unwords (forDeps Installed.ldOptions)]
366 writeFile (distdir ++ "/package-data.mk") $ unlines xs
367 writeFile (distdir ++ "/haddock-prologue.txt") $
368 if null (description pd) then synopsis pd
371 escape = foldr (\c xs -> if c == '#' then '\\':'#':xs else c:xs) []
372 wrap = map (\s -> "\'" ++ s ++ "\'")