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