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