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