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
32 main = do args <- getArgs
34 "haddock" : distDir : dir : args' ->
35 runHaddock distDir dir args'
38 "install" : ghc : ghcpkg : topdir : directory : distDir
39 : myDestDir : myPrefix : myLibdir : myDocdir : args' ->
40 doInstall ghc ghcpkg topdir directory distDir
41 myDestDir myPrefix myLibdir myDocdir args'
42 "configure" : args' -> case break (== "--") args' of
43 (config_args, "--" : distdir : directories) ->
44 mapM_ (generate config_args distdir) directories
48 syntax_error :: [String]
50 ["syntax: ghc-cabal configure <configure-args> -- <distdir> <directory>...",
51 " ghc-cabal install <ghc-pkg> <directory> <distdir> <destdir> <prefix> <args>...",
52 " ghc-cabal haddock <distdir> <directory> <args>..."]
54 die :: [String] -> IO ()
55 die errs = do mapM_ (hPutStrLn stderr) errs
56 exitWith (ExitFailure 1)
58 -- XXX Should use bracket
59 withCurrentDirectory :: FilePath -> IO a -> IO a
60 withCurrentDirectory directory io
61 = do curDirectory <- getCurrentDirectory
62 setCurrentDirectory directory
64 setCurrentDirectory curDirectory
67 -- We need to use the autoconfUserHooks, as the packages that use
68 -- configure can create a .buildinfo file, and we need any info that
70 userHooks :: UserHooks
71 userHooks = autoconfUserHooks
73 doCheck :: FilePath -> IO ()
75 = withCurrentDirectory directory
76 $ do let verbosity = normal
77 gpdFile <- defaultPackageDesc verbosity
78 gpd <- readPackageDescription verbosity gpdFile
79 case partition isFailure $ checkPackage gpd Nothing of
81 ([], warnings) -> mapM_ print warnings
82 (errs, _) -> do mapM_ print errs
83 exitWith (ExitFailure 1)
84 where isFailure (PackageDistSuspicious {}) = False
87 runHaddock :: FilePath -> FilePath -> [String] -> IO ()
88 runHaddock distdir directory args
89 = withCurrentDirectory directory
90 $ defaultMainWithHooksArgs hooks ("haddock" : "--builddir" : distdir : args)
93 haddockHook = modHook (haddockHook userHooks)
95 modHook f pd lbi us flags
96 | packageName pd == PackageName "ghc-prim"
97 = let pd' = case library pd of
99 let ghcPrim = fromJust (simpleParse "GHC.Prim")
100 ems = filter (ghcPrim /=)
102 lib' = lib { exposedModules = ems }
103 in pd { library = Just lib' }
105 error "Expected a library, but none found"
106 pc = withPrograms lbi
107 pc' = userSpecifyArgs "haddock"
108 ["dist-install/build/autogen/GHC/Prim.hs"] pc
109 lbi' = lbi { withPrograms = pc' }
110 in f pd' lbi' us flags
114 doInstall :: FilePath -> FilePath -> FilePath -> FilePath -> FilePath
115 -> FilePath -> FilePath -> FilePath -> FilePath -> [String]
117 doInstall ghc ghcpkg topdir directory distDir myDestDir myPrefix myLibdir myDocdir args
118 = withCurrentDirectory directory $ do
119 defaultMainWithHooksArgs hooks (["copy", "--builddir", distDir]
120 ++ (if null myDestDir then []
121 else ["--destdir", myDestDir])
123 defaultMainWithHooksArgs hooks ("register" : "--builddir" : distDir : args)
126 copyHook = noGhcPrimHook (modHook (copyHook userHooks)),
127 regHook = modHook (regHook userHooks)
130 noGhcPrimHook f pd lbi us flags
132 | packageName pd == PackageName "ghc-prim" =
135 let ghcPrim = fromJust (simpleParse "GHC.Prim")
136 ems = filter (ghcPrim /=) (exposedModules lib)
137 lib' = lib { exposedModules = ems }
138 in pd { library = Just lib' }
140 error "Expected a library, but none found"
142 in f pd' lbi us flags
143 modHook f pd lbi us flags
144 = do let verbosity = normal
145 idts = installDirTemplates lbi
146 idts' = idts { prefix = toPathTemplate myPrefix,
147 libdir = toPathTemplate myLibdir,
148 libsubdir = toPathTemplate "$pkgid",
149 docdir = toPathTemplate (myDocdir </> "$pkg"),
150 htmldir = toPathTemplate "$docdir" }
151 progs = withPrograms lbi
152 ghcProg = ConfiguredProgram {
153 programId = programName ghcProgram,
154 programVersion = Nothing,
155 programArgs = ["-B" ++ topdir],
156 programLocation = UserSpecified ghc
158 ghcpkgconf = topdir </> "package.conf"
159 ghcPkgProg = ConfiguredProgram {
160 programId = programName ghcPkgProgram,
161 programVersion = Nothing,
162 programArgs = ["--global-conf",
164 ++ if not (null myDestDir)
167 programLocation = UserSpecified ghcpkg
169 progs' = updateProgram ghcProg
170 $ updateProgram ghcPkgProg progs
171 instInfos <- dump verbosity ghcPkgProg GlobalPackageDB
172 let installedPkgs' = PackageIndex.listToInstalledPackageIndex
174 let mlc = libraryConfig lbi
177 let cipds = componentInstalledPackageDeps lc
178 cipds' = map (fixupPackageId instInfos) cipds
180 componentInstalledPackageDeps = cipds'
184 libraryConfig = mlc',
185 installedPkgs = installedPkgs',
186 installDirTemplates = idts',
187 withPrograms = progs'
191 -- The packages are built with the package ID ending in "-inplace", but
192 -- when they're installed they get the package hash appended. We need to
193 -- fix up the package deps so that they use the hash package IDs, not
194 -- the inplace package IDs.
195 fixupPackageId :: [Installed.InstalledPackageInfo]
196 -> InstalledPackageId
197 -> InstalledPackageId
198 fixupPackageId _ x@(InstalledPackageId ipi)
199 | "builtin:" `isPrefixOf` ipi = x
200 fixupPackageId ipinfos (InstalledPackageId ipi)
201 = case stripPrefix (reverse "-inplace") $ reverse ipi of
203 error ("Installed package ID doesn't end in -inplace: " ++ show ipi)
205 let ipi' = reverse ('-' : x)
206 f (ipinfo : ipinfos') = case Installed.installedPackageId ipinfo of
207 y@(InstalledPackageId ipinfoid)
208 | ipi' `isPrefixOf` ipinfoid ->
212 f [] = error ("Installed package ID not registered: " ++ show ipi)
215 generate :: [String] -> FilePath -> FilePath -> IO ()
216 generate config_args distdir directory
217 = withCurrentDirectory directory
218 $ do let verbosity = normal
219 gpdFile <- defaultPackageDesc verbosity
220 gpd <- readPackageDescription verbosity gpdFile
222 -- XXX We shouldn't just configure with the default flags
223 -- XXX And this, and thus the "getPersistBuildConfig distdir" below,
224 -- aren't going to work when the deps aren't built yet
225 withArgs (["configure", "--distdir", distdir] ++ config_args)
226 (case buildType (flattenPackageDescription gpd) of
227 Just Configure -> defaultMainWithHooks autoconfUserHooks
228 -- time has a "Custom" Setup.hs, but it's actually Configure
229 -- plus a "./Setup test" hook. However, Cabal is also
230 -- "Custom", but doesn't have a configure script.
232 do configureExists <- doesFileExist "configure"
234 then defaultMainWithHooks autoconfUserHooks
236 -- not quite right, but good enough for us:
239 lbi <- getPersistBuildConfig distdir
240 let pd0 = localPkgDescr lbi
243 if (buildType pd0 == Just Configure) || (buildType pd0 == Just Custom)
245 maybe_infoFile <- defaultHookedPackageDesc
246 case maybe_infoFile of
247 Nothing -> return emptyHookedBuildInfo
248 Just infoFile -> readHookedBuildInfo verbosity infoFile
250 return emptyHookedBuildInfo
252 let pd = updatePackageDescription hooked_bi pd0
254 -- generate Paths_<pkg>.hs and cabal-macros.h
255 writeAutogenFiles verbosity pd lbi
257 -- generate inplace-pkg-config
258 case (library pd, libraryConfig lbi) of
259 (Nothing, Nothing) -> return ()
260 (Just lib, Just clbi) -> do
261 cwd <- getCurrentDirectory
262 let ipid = InstalledPackageId (display (packageId pd) ++ "-inplace")
263 let installedPkgInfo = inplaceInstalledPackageInfo cwd distdir
265 final_ipi = installedPkgInfo{ Installed.installedPackageId = ipid }
266 content = Installed.showInstalledPackageInfo final_ipi ++ "\n"
267 writeFileAtomic (distdir </> "inplace-pkg-config") content
268 _ -> error "Inconsistent lib components; can't happen?"
271 libBiModules lib = (libBuildInfo lib, libModules lib)
272 exeBiModules exe = (buildInfo exe, ModuleName.main : exeModules exe)
273 biModuless = (maybeToList $ fmap libBiModules $ library pd)
274 ++ (map exeBiModules $ executables pd)
275 buildableBiModuless = filter isBuildable biModuless
276 where isBuildable (bi', _) = buildable bi'
277 (bi, modules) = case buildableBiModuless of
278 [] -> error "No buildable component found"
279 [biModules] -> biModules
280 _ -> error ("XXX ghc-cabal can't handle " ++
281 "more than one buildinfo yet")
282 -- XXX Another Just...
283 Just ghcProg = lookupProgram ghcProgram (withPrograms lbi)
285 dep_pkgs = PackageIndex.topologicalOrder (packageHacks (installedPkgs lbi))
286 forDeps f = concatMap f dep_pkgs
288 -- copied from Distribution.Simple.PreProcess.ppHsc2Hs
289 packageHacks = case compilerFlavor (compiler lbi) of
290 GHC -> hackRtsPackage
292 -- We don't link in the actual Haskell libraries of our
293 -- dependencies, so the -u flags in the ldOptions of the rts
294 -- package mean linking fails on OS X (it's ld is a tad
295 -- stricter than gnu ld). Thus we remove the ldOptions for
296 -- GHC's rts package:
297 hackRtsPackage index =
298 case PackageIndex.lookupInstalledPackageByName index (PackageName "rts") of
299 [rts] -> PackageIndex.addToInstalledPackageIndex rts { Installed.ldOptions = [] } index
300 _ -> error "No (or multiple) ghc rts package is registered!!"
302 dep_ids = map (packageId.getLocalPackageInfo lbi) $
303 externalPackageDeps lbi
305 let variablePrefix = directory ++ '_':distdir
306 let xs = [variablePrefix ++ "_VERSION = " ++ display (pkgVersion (package pd)),
307 variablePrefix ++ "_MODULES = " ++ unwords (map display modules),
308 variablePrefix ++ "_HS_SRC_DIRS = " ++ unwords (hsSourceDirs bi),
309 variablePrefix ++ "_DEPS = " ++ unwords (map display dep_ids),
310 variablePrefix ++ "_DEP_NAMES = " ++ unwords (map (display . packageName) dep_ids),
311 variablePrefix ++ "_INCLUDE_DIRS = " ++ unwords (includeDirs bi),
312 variablePrefix ++ "_INCLUDES = " ++ unwords (includes bi),
313 variablePrefix ++ "_INSTALL_INCLUDES = " ++ unwords (installIncludes bi),
314 variablePrefix ++ "_EXTRA_LIBRARIES = " ++ unwords (extraLibs bi),
315 variablePrefix ++ "_EXTRA_LIBDIRS = " ++ unwords (extraLibDirs bi),
316 variablePrefix ++ "_C_SRCS = " ++ unwords (cSources bi),
317 variablePrefix ++ "_CMM_SRCS = $(addprefix cbits/,$(notdir $(wildcard " ++ directory ++ "/cbits/*.cmm)))",
318 -- XXX This includes things it shouldn't, like:
319 -- -odir dist-bootstrapping/build
320 variablePrefix ++ "_HC_OPTS = " ++ escape (unwords
323 ++ extensionsToFlags (compiler lbi) (extensions bi))),
324 variablePrefix ++ "_CC_OPTS = " ++ unwords (ccOptions bi),
325 variablePrefix ++ "_CPP_OPTS = " ++ unwords (cppOptions bi),
326 variablePrefix ++ "_LD_OPTS = " ++ unwords (ldOptions bi),
327 variablePrefix ++ "_DEP_INCLUDE_DIRS = " ++ unwords (forDeps Installed.includeDirs),
328 variablePrefix ++ "_DEP_CC_OPTS = " ++ unwords (forDeps Installed.ccOptions),
329 variablePrefix ++ "_DEP_LIB_DIRS = " ++ unwords (forDeps Installed.libraryDirs),
330 variablePrefix ++ "_DEP_EXTRA_LIBS = " ++ unwords (forDeps Installed.extraLibraries),
331 variablePrefix ++ "_DEP_LD_OPTS = " ++ unwords (forDeps Installed.ldOptions)]
332 writeFile (distdir ++ "/package-data.mk") $ unlines xs
334 escape = foldr (\c xs -> if c == '#' then '\\':'#':xs else c:xs) []