Move the RPATH computation into the build rules
[ghc.git] / utils / ghc-cabal / Main.hs
1
2 module Main (main) where
3
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, toUTF8)
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
21
22 import Control.Monad
23 import qualified Data.ByteString.Lazy.Char8 as BS
24 import Data.List
25 import Data.Maybe
26 import System.IO
27 import System.Directory
28 import System.Environment
29 import System.Exit
30 import System.FilePath
31
32 main :: IO ()
33 main = do hSetBuffering stdout LineBuffering
34 args <- getArgs
35 case args of
36 "hscolour" : distDir : dir : args' ->
37 runHsColour distDir dir args'
38 "check" : dir : [] ->
39 doCheck dir
40 "copy" : strip : directory : distDir
41 : myDestDir : myPrefix : myLibdir : myDocdir
42 : args' ->
43 doCopy strip directory distDir
44 myDestDir myPrefix myLibdir myDocdir
45 args'
46 "register" : ghc : ghcpkg : topdir : directory : distDir
47 : myDestDir : myPrefix : myLibdir : myDocdir
48 : relocatableBuild : args' ->
49 doRegister ghc ghcpkg topdir directory distDir
50 myDestDir myPrefix myLibdir myDocdir
51 relocatableBuild args'
52 "configure" : args' -> case break (== "--") args' of
53 (config_args, "--" : distdir : directories) ->
54 mapM_ (generate config_args distdir) directories
55 _ -> die syntax_error
56 "sdist" : dir : distDir : [] ->
57 doSdist dir distDir
58 ["--version"] ->
59 defaultMainArgs ["--version"]
60 _ -> die syntax_error
61
62 syntax_error :: [String]
63 syntax_error =
64 ["syntax: ghc-cabal configure <configure-args> -- <distdir> <directory>...",
65 " ghc-cabal install <ghc-pkg> <directory> <distdir> <destdir> <prefix> <args>...",
66 " ghc-cabal hscolour <distdir> <directory> <args>..."]
67
68 die :: [String] -> IO a
69 die errs = do mapM_ (hPutStrLn stderr) errs
70 exitWith (ExitFailure 1)
71
72 -- XXX Should use bracket
73 withCurrentDirectory :: FilePath -> IO a -> IO a
74 withCurrentDirectory directory io
75 = do curDirectory <- getCurrentDirectory
76 setCurrentDirectory directory
77 r <- io
78 setCurrentDirectory curDirectory
79 return r
80
81 -- We need to use the autoconfUserHooks, as the packages that use
82 -- configure can create a .buildinfo file, and we need any info that
83 -- ends up in it.
84 userHooks :: UserHooks
85 userHooks = autoconfUserHooks
86
87 runDefaultMain :: IO ()
88 runDefaultMain
89 = do let verbosity = normal
90 gpdFile <- defaultPackageDesc verbosity
91 gpd <- readPackageDescription verbosity gpdFile
92 case buildType (flattenPackageDescription gpd) of
93 Just Configure -> defaultMainWithHooks autoconfUserHooks
94 -- time has a "Custom" Setup.hs, but it's actually Configure
95 -- plus a "./Setup test" hook. However, Cabal is also
96 -- "Custom", but doesn't have a configure script.
97 Just Custom ->
98 do configureExists <- doesFileExist "configure"
99 if configureExists
100 then defaultMainWithHooks autoconfUserHooks
101 else defaultMain
102 -- not quite right, but good enough for us:
103 _ -> defaultMain
104
105 doSdist :: FilePath -> FilePath -> IO ()
106 doSdist directory distDir
107 = withCurrentDirectory directory
108 $ withArgs (["sdist", "--builddir", distDir])
109 runDefaultMain
110
111 doCheck :: FilePath -> IO ()
112 doCheck directory
113 = withCurrentDirectory directory
114 $ do let verbosity = normal
115 gpdFile <- defaultPackageDesc verbosity
116 gpd <- readPackageDescription verbosity gpdFile
117 case partition isFailure $ checkPackage gpd Nothing of
118 ([], []) -> return ()
119 ([], warnings) -> mapM_ print warnings
120 (errs, _) -> do mapM_ print errs
121 exitWith (ExitFailure 1)
122 where isFailure (PackageDistSuspicious {}) = False
123 isFailure _ = True
124
125 runHsColour :: FilePath -> FilePath -> [String] -> IO ()
126 runHsColour distdir directory args
127 = withCurrentDirectory directory
128 $ defaultMainArgs ("hscolour" : "--builddir" : distdir : args)
129
130 doCopy :: FilePath -> FilePath
131 -> FilePath -> FilePath -> FilePath -> FilePath -> FilePath
132 -> [String]
133 -> IO ()
134 doCopy strip directory distDir
135 myDestDir myPrefix myLibdir myDocdir
136 args
137 = withCurrentDirectory directory $ do
138 let copyArgs = ["copy", "--builddir", distDir]
139 ++ (if null myDestDir
140 then []
141 else ["--destdir", myDestDir])
142 ++ args
143 copyHooks = userHooks {
144 copyHook = noGhcPrimHook
145 $ modHook False
146 $ copyHook userHooks
147 }
148
149 defaultMainWithHooksArgs copyHooks copyArgs
150 where
151 noGhcPrimHook f pd lbi us flags
152 = let pd'
153 | packageName pd == PackageName "ghc-prim" =
154 case library pd of
155 Just lib ->
156 let ghcPrim = fromJust (simpleParse "GHC.Prim")
157 ems = filter (ghcPrim /=) (exposedModules lib)
158 lib' = lib { exposedModules = ems }
159 in pd { library = Just lib' }
160 Nothing ->
161 error "Expected a library, but none found"
162 | otherwise = pd
163 in f pd' lbi us flags
164 modHook relocatableBuild f pd lbi us flags
165 = do let verbosity = normal
166 idts = updateInstallDirTemplates relocatableBuild
167 myPrefix myLibdir myDocdir
168 (installDirTemplates lbi)
169 progs = withPrograms lbi
170 stripProgram' = stripProgram {
171 programFindLocation = \_ -> return (Just strip) }
172
173 progs' <- configureProgram verbosity stripProgram' progs
174 let lbi' = lbi {
175 withPrograms = progs',
176 installDirTemplates = idts
177 }
178 f pd lbi' us flags
179
180 doRegister :: FilePath -> FilePath -> FilePath -> FilePath
181 -> FilePath -> FilePath -> FilePath -> FilePath -> FilePath
182 -> String -> [String]
183 -> IO ()
184 doRegister ghc ghcpkg topdir directory distDir
185 myDestDir myPrefix myLibdir myDocdir
186 relocatableBuildStr args
187 = withCurrentDirectory directory $ do
188 relocatableBuild <- case relocatableBuildStr of
189 "YES" -> return True
190 "NO" -> return False
191 _ -> die ["Bad relocatableBuildStr: " ++
192 show relocatableBuildStr]
193 let regArgs = "register" : "--builddir" : distDir : args
194 regHooks = userHooks {
195 regHook = modHook relocatableBuild
196 $ regHook userHooks
197 }
198
199 defaultMainWithHooksArgs regHooks regArgs
200 where
201 modHook relocatableBuild f pd lbi us flags
202 = do let verbosity = normal
203 idts = updateInstallDirTemplates relocatableBuild
204 myPrefix myLibdir myDocdir
205 (installDirTemplates lbi)
206 progs = withPrograms lbi
207 ghcpkgconf = topdir </> "package.conf.d"
208 ghcProgram' = ghcProgram {
209 programPostConf = \_ _ -> return ["-B" ++ topdir],
210 programFindLocation = \_ -> return (Just ghc) }
211 ghcPkgProgram' = ghcPkgProgram {
212 programPostConf = \_ _ -> return $ ["--global-package-db", ghcpkgconf]
213 ++ ["--force" | not (null myDestDir) ],
214 programFindLocation = \_ -> return (Just ghcpkg) }
215 configurePrograms ps conf = foldM (flip (configureProgram verbosity)) conf ps
216
217 progs' <- configurePrograms [ghcProgram', ghcPkgProgram'] progs
218 let Just ghcPkgProg = lookupProgram ghcPkgProgram' progs'
219 instInfos <- dump verbosity ghcPkgProg GlobalPackageDB
220 let installedPkgs' = PackageIndex.fromList instInfos
221 let mlc = libraryConfig lbi
222 mlc' = case mlc of
223 Just lc ->
224 let cipds = componentPackageDeps lc
225 cipds' = [ (fixupPackageId instInfos ipid, pid)
226 | (ipid,pid) <- cipds ]
227 in Just $ lc {
228 componentPackageDeps = cipds'
229 }
230 Nothing -> Nothing
231 lbi' = lbi {
232 libraryConfig = mlc',
233 installedPkgs = installedPkgs',
234 installDirTemplates = idts,
235 withPrograms = progs'
236 }
237 f pd lbi' us flags
238
239 updateInstallDirTemplates :: Bool -> FilePath -> FilePath -> FilePath
240 -> InstallDirTemplates
241 -> InstallDirTemplates
242 updateInstallDirTemplates relocatableBuild myPrefix myLibdir myDocdir idts
243 = idts {
244 prefix = toPathTemplate $
245 if relocatableBuild
246 then "$topdir"
247 else myPrefix,
248 libdir = toPathTemplate $
249 if relocatableBuild
250 then "$topdir"
251 else myLibdir,
252 libsubdir = toPathTemplate "$pkgid",
253 docdir = toPathTemplate $
254 if relocatableBuild
255 then "$topdir/../doc/html/libraries/$pkgid"
256 else (myDocdir </> "$pkgid"),
257 htmldir = toPathTemplate "$docdir"
258 }
259
260 -- The packages are built with the package ID ending in "-inplace", but
261 -- when they're installed they get the package hash appended. We need to
262 -- fix up the package deps so that they use the hash package IDs, not
263 -- the inplace package IDs.
264 fixupPackageId :: [Installed.InstalledPackageInfo]
265 -> InstalledPackageId
266 -> InstalledPackageId
267 fixupPackageId _ x@(InstalledPackageId ipi)
268 | "builtin_" `isPrefixOf` ipi = x
269 fixupPackageId ipinfos (InstalledPackageId ipi)
270 = case stripPrefix (reverse "-inplace") $ reverse ipi of
271 Nothing ->
272 error ("Installed package ID doesn't end in -inplace: " ++ show ipi)
273 Just x ->
274 let ipi' = reverse ('-' : x)
275 f (ipinfo : ipinfos') = case Installed.installedPackageId ipinfo of
276 y@(InstalledPackageId ipinfoid)
277 | ipi' `isPrefixOf` ipinfoid ->
278 y
279 _ ->
280 f ipinfos'
281 f [] = error ("Installed package ID not registered: " ++ show ipi)
282 in f ipinfos
283
284 generate :: [String] -> FilePath -> FilePath -> IO ()
285 generate config_args distdir directory
286 = withCurrentDirectory directory
287 $ do let verbosity = normal
288 -- XXX We shouldn't just configure with the default flags
289 -- XXX And this, and thus the "getPersistBuildConfig distdir" below,
290 -- aren't going to work when the deps aren't built yet
291 withArgs (["configure", "--distdir", distdir] ++ config_args)
292 runDefaultMain
293
294 lbi <- getPersistBuildConfig distdir
295 let pd0 = localPkgDescr lbi
296
297 hooked_bi <-
298 if (buildType pd0 == Just Configure) || (buildType pd0 == Just Custom)
299 then do
300 maybe_infoFile <- defaultHookedPackageDesc
301 case maybe_infoFile of
302 Nothing -> return emptyHookedBuildInfo
303 Just infoFile -> readHookedBuildInfo verbosity infoFile
304 else
305 return emptyHookedBuildInfo
306
307 let pd = updatePackageDescription hooked_bi pd0
308
309 -- generate Paths_<pkg>.hs and cabal-macros.h
310 writeAutogenFiles verbosity pd lbi
311
312 -- generate inplace-pkg-config
313 case (library pd, libraryConfig lbi) of
314 (Nothing, Nothing) -> return ()
315 (Just lib, Just clbi) -> do
316 cwd <- getCurrentDirectory
317 let ipid = InstalledPackageId (display (packageId pd) ++ "-inplace")
318 let installedPkgInfo = inplaceInstalledPackageInfo cwd distdir
319 pd lib lbi clbi
320 final_ipi = installedPkgInfo {
321 Installed.installedPackageId = ipid,
322 Installed.haddockHTMLs = []
323 }
324 content = Installed.showInstalledPackageInfo final_ipi ++ "\n"
325 writeFileAtomic (distdir </> "inplace-pkg-config") (BS.pack $ toUTF8 content)
326 _ -> error "Inconsistent lib components; can't happen?"
327
328 let
329 libBiModules lib = (libBuildInfo lib, libModules lib)
330 exeBiModules exe = (buildInfo exe, ModuleName.main : exeModules exe)
331 biModuless = (maybeToList $ fmap libBiModules $ library pd)
332 ++ (map exeBiModules $ executables pd)
333 buildableBiModuless = filter isBuildable biModuless
334 where isBuildable (bi', _) = buildable bi'
335 (bi, modules) = case buildableBiModuless of
336 [] -> error "No buildable component found"
337 [biModules] -> biModules
338 _ -> error ("XXX ghc-cabal can't handle " ++
339 "more than one buildinfo yet")
340 -- XXX Another Just...
341 Just ghcProg = lookupProgram ghcProgram (withPrograms lbi)
342
343 dep_pkgs = PackageIndex.topologicalOrder (packageHacks (installedPkgs lbi))
344 forDeps f = concatMap f dep_pkgs
345
346 -- copied from Distribution.Simple.PreProcess.ppHsc2Hs
347 packageHacks = case compilerFlavor (compiler lbi) of
348 GHC -> hackRtsPackage
349 _ -> id
350 -- We don't link in the actual Haskell libraries of our
351 -- dependencies, so the -u flags in the ldOptions of the rts
352 -- package mean linking fails on OS X (it's ld is a tad
353 -- stricter than gnu ld). Thus we remove the ldOptions for
354 -- GHC's rts package:
355 hackRtsPackage index =
356 case PackageIndex.lookupPackageName index (PackageName "rts") of
357 [(_,[rts])] ->
358 PackageIndex.insert rts{
359 Installed.ldOptions = [],
360 Installed.libraryDirs = filter (not . ("gcc-lib" `isSuffixOf`)) (Installed.libraryDirs rts)} index
361 -- GHC <= 6.12 had $topdir/gcc-lib in their
362 -- library-dirs for the rts package, which causes
363 -- problems when we try to use the in-tree mingw,
364 -- due to accidentally picking up the incompatible
365 -- libraries there. So we filter out gcc-lib from
366 -- the RTS's library-dirs here.
367 _ -> error "No (or multiple) ghc rts package is registered!!"
368
369 dep_ids = map snd (externalPackageDeps lbi)
370
371 let libraryDirs = forDeps Installed.libraryDirs
372 transitive_dep_ids = map Installed.sourcePackageId dep_pkgs
373 wrappedIncludeDirs <- wrap $ forDeps Installed.includeDirs
374 wrappedLibraryDirs <- wrap libraryDirs
375
376 let variablePrefix = directory ++ '_':distdir
377 let xs = [variablePrefix ++ "_VERSION = " ++ display (pkgVersion (package pd)),
378 variablePrefix ++ "_MODULES = " ++ unwords (map display modules),
379 variablePrefix ++ "_HIDDEN_MODULES = " ++ unwords (map display (otherModules bi)),
380 variablePrefix ++ "_SYNOPSIS =" ++ synopsis pd,
381 variablePrefix ++ "_HS_SRC_DIRS = " ++ unwords (hsSourceDirs bi),
382 variablePrefix ++ "_DEPS = " ++ unwords (map display dep_ids),
383 variablePrefix ++ "_DEP_NAMES = " ++ unwords (map (display . packageName) dep_ids),
384 variablePrefix ++ "_TRANSITIVE_DEPS = " ++ unwords (map display transitive_dep_ids),
385 variablePrefix ++ "_TRANSITIVE_DEP_NAMES = " ++ unwords (map (display . packageName) transitive_dep_ids),
386 variablePrefix ++ "_INCLUDE_DIRS = " ++ unwords (includeDirs bi),
387 variablePrefix ++ "_INCLUDES = " ++ unwords (includes bi),
388 variablePrefix ++ "_INSTALL_INCLUDES = " ++ unwords (installIncludes bi),
389 variablePrefix ++ "_EXTRA_LIBRARIES = " ++ unwords (extraLibs bi),
390 variablePrefix ++ "_EXTRA_LIBDIRS = " ++ unwords (extraLibDirs bi),
391 variablePrefix ++ "_C_SRCS = " ++ unwords (cSources bi),
392 variablePrefix ++ "_CMM_SRCS := $(addprefix cbits/,$(notdir $(wildcard " ++ directory ++ "/cbits/*.cmm)))",
393 variablePrefix ++ "_DATA_FILES = " ++ unwords (dataFiles pd),
394 -- XXX This includes things it shouldn't, like:
395 -- -odir dist-bootstrapping/build
396 variablePrefix ++ "_HC_OPTS = " ++ escape (unwords
397 ( programDefaultArgs ghcProg
398 ++ hcOptions GHC bi
399 ++ languageToFlags (compiler lbi) (defaultLanguage bi)
400 ++ extensionsToFlags (compiler lbi) (usedExtensions bi)
401 ++ programOverrideArgs ghcProg)),
402 variablePrefix ++ "_CC_OPTS = " ++ unwords (ccOptions bi),
403 variablePrefix ++ "_CPP_OPTS = " ++ unwords (cppOptions bi),
404 variablePrefix ++ "_LD_OPTS = " ++ unwords (ldOptions bi),
405 variablePrefix ++ "_DEP_INCLUDE_DIRS_SINGLE_QUOTED = " ++ unwords wrappedIncludeDirs,
406 variablePrefix ++ "_DEP_CC_OPTS = " ++ unwords (forDeps Installed.ccOptions),
407 variablePrefix ++ "_DEP_LIB_DIRS_SINGLE_QUOTED = " ++ unwords wrappedLibraryDirs,
408 variablePrefix ++ "_DEP_LIB_DIRS_SEARCHPATH = " ++ mkSearchPath libraryDirs,
409 variablePrefix ++ "_DEP_EXTRA_LIBS = " ++ unwords (forDeps Installed.extraLibraries),
410 variablePrefix ++ "_DEP_LD_OPTS = " ++ unwords (forDeps Installed.ldOptions),
411 variablePrefix ++ "_BUILD_GHCI_LIB = " ++ boolToYesNo (withGHCiLib lbi),
412 "",
413 -- Sometimes we need to modify the automatically-generated package-data.mk
414 -- bindings in a special way for the GHC build system, so allow that here:
415 "$(eval $(" ++ directory ++ "_PACKAGE_MAGIC))"
416 ]
417 writeFile (distdir ++ "/package-data.mk") $ unlines xs
418 writeFile (distdir ++ "/haddock-prologue.txt") $
419 if null (description pd) then synopsis pd
420 else description pd
421 where
422 escape = foldr (\c xs -> if c == '#' then '\\':'#':xs else c:xs) []
423 wrap = mapM wrap1
424 wrap1 s
425 | null s = die ["Wrapping empty value"]
426 | '\'' `elem` s = die ["Single quote in value to be wrapped:", s]
427 -- We want to be able to assume things like <space><quote> is the
428 -- start of a value, so check there are no spaces in confusing
429 -- positions
430 | head s == ' ' = die ["Leading space in value to be wrapped:", s]
431 | last s == ' ' = die ["Trailing space in value to be wrapped:", s]
432 | otherwise = return ("\'" ++ s ++ "\'")
433 mkSearchPath = intercalate [searchPathSeparator]
434 boolToYesNo True = "YES"
435 boolToYesNo False = "NO"