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