Make ghc-cabal's `System.Directory` import more robust
[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.Package
10 import Distribution.System
11 import Distribution.Simple
12 import Distribution.Simple.Configure
13 import Distribution.Simple.LocalBuildInfo
14 import Distribution.Simple.GHC
15 import Distribution.Simple.Program
16 import Distribution.Simple.Program.HcPkg
17 import Distribution.Simple.Setup (ConfigFlags(configStripLibs), fromFlag, toFlag)
18 import Distribution.Simple.Utils (defaultPackageDesc, writeFileAtomic, toUTF8)
19 import Distribution.Simple.Build (writeAutogenFiles)
20 import Distribution.Simple.Register
21 import Distribution.Text
22 import Distribution.Verbosity
23 import qualified Distribution.InstalledPackageInfo as Installed
24 import qualified Distribution.Simple.PackageIndex as PackageIndex
25
26 import Control.Exception (bracket)
27 import Control.Monad
28 import qualified Data.ByteString.Lazy.Char8 as BS
29 import Data.List
30 import Data.Maybe
31 import System.IO
32 import System.Directory (setCurrentDirectory, getCurrentDirectory, doesFileExist)
33 import System.Environment
34 import System.Exit (exitWith, ExitCode(..))
35 import System.FilePath
36
37 main :: IO ()
38 main = do hSetBuffering stdout LineBuffering
39 args <- getArgs
40 case args of
41 "hscolour" : dir : distDir : args' ->
42 runHsColour dir distDir args'
43 "check" : dir : [] ->
44 doCheck dir
45 "copy" : dir : distDir
46 : strip : myDestDir : myPrefix : myLibdir : myDocdir
47 : ghcLibWays : args' ->
48 doCopy dir distDir
49 strip myDestDir myPrefix myLibdir myDocdir
50 ("dyn" `elem` words ghcLibWays)
51 args'
52 "register" : dir : distDir : ghc : ghcpkg : topdir
53 : myDestDir : myPrefix : myLibdir : myDocdir
54 : relocatableBuild : args' ->
55 doRegister dir distDir ghc ghcpkg topdir
56 myDestDir myPrefix myLibdir myDocdir
57 relocatableBuild args'
58 "configure" : dir : distDir : dll0Modules : config_args ->
59 generate dir distDir dll0Modules config_args
60 "sdist" : dir : distDir : [] ->
61 doSdist dir distDir
62 ["--version"] ->
63 defaultMainArgs ["--version"]
64 _ -> die syntax_error
65
66 syntax_error :: [String]
67 syntax_error =
68 ["syntax: ghc-cabal configure <configure-args> -- <distdir> <directory>...",
69 " ghc-cabal install <ghc-pkg> <directory> <distdir> <destdir> <prefix> <args>...",
70 " ghc-cabal hscolour <distdir> <directory> <args>..."]
71
72 die :: [String] -> IO a
73 die errs = do mapM_ (hPutStrLn stderr) errs
74 exitWith (ExitFailure 1)
75
76 withCurrentDirectory :: FilePath -> IO a -> IO a
77 withCurrentDirectory directory io
78 = bracket (getCurrentDirectory) (setCurrentDirectory)
79 (const (setCurrentDirectory directory >> io))
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 filter isFailure $ checkPackage gpd Nothing of
118 [] -> return ()
119 errs -> mapM_ print errs >> exitWith (ExitFailure 1)
120 where isFailure (PackageDistSuspicious {}) = False
121 isFailure (PackageDistSuspiciousWarn {}) = False
122 isFailure _ = True
123
124 runHsColour :: FilePath -> FilePath -> [String] -> IO ()
125 runHsColour directory distdir args
126 = withCurrentDirectory directory
127 $ defaultMainArgs ("hscolour" : "--builddir" : distdir : args)
128
129 doCopy :: FilePath -> FilePath
130 -> FilePath -> FilePath -> FilePath -> FilePath -> FilePath -> Bool
131 -> [String]
132 -> IO ()
133 doCopy directory distDir
134 strip myDestDir myPrefix myLibdir myDocdir withSharedLibs
135 args
136 = withCurrentDirectory directory $ do
137 let copyArgs = ["copy", "--builddir", distDir]
138 ++ (if null myDestDir
139 then []
140 else ["--destdir", myDestDir])
141 ++ args
142 copyHooks = userHooks {
143 copyHook = noGhcPrimHook
144 $ modHook False
145 $ copyHook userHooks
146 }
147
148 defaultMainWithHooksArgs copyHooks copyArgs
149 where
150 noGhcPrimHook f pd lbi us flags
151 = let pd'
152 | packageName pd == PackageName "ghc-prim" =
153 case library pd of
154 Just lib ->
155 let ghcPrim = fromJust (simpleParse "GHC.Prim")
156 ems = filter (ghcPrim /=) (exposedModules lib)
157 lib' = lib { exposedModules = ems }
158 in pd { library = Just lib' }
159 Nothing ->
160 error "Expected a library, but none found"
161 | otherwise = pd
162 in f pd' lbi us flags
163 modHook relocatableBuild f pd lbi us flags
164 = do let verbosity = normal
165 idts = updateInstallDirTemplates relocatableBuild
166 myPrefix myLibdir myDocdir
167 (installDirTemplates lbi)
168 progs = withPrograms lbi
169 stripProgram' = stripProgram {
170 programFindLocation = \_ _ -> return (Just strip) }
171
172 progs' <- configureProgram verbosity stripProgram' progs
173 let lbi' = lbi {
174 withPrograms = progs',
175 installDirTemplates = idts,
176 configFlags = cfg,
177 stripLibs = fromFlag (configStripLibs cfg),
178 withSharedLib = withSharedLibs
179 }
180
181 -- This hack allows to interpret the "strip"
182 -- command-line argument being set to ':' to signify
183 -- disabled library stripping
184 cfg | strip == ":" = (configFlags lbi) { configStripLibs = toFlag False }
185 | otherwise = configFlags lbi
186
187 f pd lbi' us flags
188
189 doRegister :: FilePath -> FilePath -> FilePath -> FilePath
190 -> FilePath -> FilePath -> FilePath -> FilePath -> FilePath
191 -> String -> [String]
192 -> IO ()
193 doRegister directory distDir ghc ghcpkg topdir
194 myDestDir myPrefix myLibdir myDocdir
195 relocatableBuildStr args
196 = withCurrentDirectory directory $ do
197 relocatableBuild <- case relocatableBuildStr of
198 "YES" -> return True
199 "NO" -> return False
200 _ -> die ["Bad relocatableBuildStr: " ++
201 show relocatableBuildStr]
202 let regArgs = "register" : "--builddir" : distDir : args
203 regHooks = userHooks {
204 regHook = modHook relocatableBuild
205 $ regHook userHooks
206 }
207
208 defaultMainWithHooksArgs regHooks regArgs
209 where
210 modHook relocatableBuild f pd lbi us flags
211 = do let verbosity = normal
212 idts = updateInstallDirTemplates relocatableBuild
213 myPrefix myLibdir myDocdir
214 (installDirTemplates lbi)
215 progs = withPrograms lbi
216 ghcpkgconf = topdir </> "package.conf.d"
217 ghcProgram' = ghcProgram {
218 programPostConf = \_ cp -> return cp { programDefaultArgs = ["-B" ++ topdir] },
219 programFindLocation = \_ _ -> return (Just ghc) }
220 ghcPkgProgram' = ghcPkgProgram {
221 programPostConf = \_ cp -> return cp { programDefaultArgs =
222 ["--global-package-db", ghcpkgconf]
223 ++ ["--force" | not (null myDestDir) ] },
224 programFindLocation = \_ _ -> return (Just ghcpkg) }
225 configurePrograms ps conf = foldM (flip (configureProgram verbosity)) conf ps
226
227 progs' <- configurePrograms [ghcProgram', ghcPkgProgram'] progs
228 instInfos <- dump (hcPkgInfo progs') verbosity GlobalPackageDB
229 let installedPkgs' = PackageIndex.fromList instInfos
230 let updateComponentConfig (cn, clbi, deps)
231 = (cn, updateComponentLocalBuildInfo clbi, deps)
232 updateComponentLocalBuildInfo clbi = clbi -- TODO: remove
233 ccs' = map updateComponentConfig (componentsConfigs lbi)
234 lbi' = lbi {
235 componentsConfigs = ccs',
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 libsubdir = toPathTemplate "$libname",
256 docdir = toPathTemplate $
257 if relocatableBuild
258 then "$topdir/../doc/html/libraries/$pkgid"
259 else (myDocdir </> "$pkgid"),
260 htmldir = toPathTemplate "$docdir"
261 }
262
263 -- On Windows we need to split the ghc package into 2 pieces, or the
264 -- DLL that it makes contains too many symbols (#5987). There are
265 -- therefore 2 libraries, not just the 1 that Cabal assumes.
266 mangleIPI :: FilePath -> FilePath -> LocalBuildInfo
267 -> Installed.InstalledPackageInfo -> Installed.InstalledPackageInfo
268 mangleIPI "compiler" "stage2" lbi ipi
269 | isWindows =
270 -- Cabal currently only ever installs ONE Haskell library, c.f.
271 -- the code in Cabal.Distribution.Simple.Register. If it
272 -- ever starts installing more we'll have to find the
273 -- library that's too big and split that.
274 let [old_hslib] = Installed.hsLibraries ipi
275 in ipi {
276 Installed.hsLibraries = [old_hslib, old_hslib ++ "-0"]
277 }
278 where isWindows = case hostPlatform lbi of
279 Platform _ Windows -> True
280 _ -> False
281 mangleIPI _ _ _ ipi = ipi
282
283 generate :: FilePath -> FilePath -> String -> [String] -> IO ()
284 generate directory distdir dll0Modules config_args
285 = withCurrentDirectory directory
286 $ do let verbosity = normal
287 -- XXX We shouldn't just configure with the default flags
288 -- XXX And this, and thus the "getPersistBuildConfig distdir" below,
289 -- aren't going to work when the deps aren't built yet
290 withArgs (["configure", "--distdir", distdir, "--ipid", "$pkg-$version"] ++ config_args)
291 runDefaultMain
292
293 lbi <- getPersistBuildConfig distdir
294 let pd0 = localPkgDescr lbi
295
296 writePersistBuildConfig distdir lbi
297
298 hooked_bi <-
299 if (buildType pd0 == Just Configure) || (buildType pd0 == Just Custom)
300 then do
301 maybe_infoFile <- defaultHookedPackageDesc
302 case maybe_infoFile of
303 Nothing -> return emptyHookedBuildInfo
304 Just infoFile -> readHookedBuildInfo verbosity infoFile
305 else
306 return emptyHookedBuildInfo
307
308 let pd = updatePackageDescription hooked_bi pd0
309
310 -- generate Paths_<pkg>.hs and cabal-macros.h
311 writeAutogenFiles verbosity pd lbi
312
313 -- generate inplace-pkg-config
314 withLibLBI pd lbi $ \lib clbi ->
315 do cwd <- getCurrentDirectory
316 let ipid = ComponentId (display (packageId pd))
317 let installedPkgInfo = inplaceInstalledPackageInfo cwd distdir
318 pd (Installed.AbiHash "") lib lbi clbi
319 final_ipi = mangleIPI directory distdir lbi $ installedPkgInfo {
320 Installed.installedComponentId = ipid,
321 Installed.compatPackageKey = ipid,
322 Installed.haddockHTMLs = []
323 }
324 content = Installed.showInstalledPackageInfo final_ipi ++ "\n"
325 writeFileAtomic (distdir </> "inplace-pkg-config") (BS.pack $ toUTF8 content)
326
327 let
328 comp = compiler lbi
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 deps = map display dep_ids
371 dep_direct = map (fromMaybe (error "ghc-cabal: dep_keys failed")
372 . PackageIndex.lookupComponentId
373 (installedPkgs lbi)
374 . fst)
375 . externalPackageDeps
376 $ lbi
377 dep_ipids = map (display . Installed.installedComponentId) dep_direct
378 depLibNames
379 | packageKeySupported comp = dep_ipids
380 | otherwise = deps
381 depNames = map (display . packageName) dep_ids
382
383 transitive_dep_ids = map Installed.sourcePackageId dep_pkgs
384 transitiveDeps = map display transitive_dep_ids
385 transitiveDepLibNames
386 | packageKeySupported comp = map fixupRtsLibName transitiveDeps
387 | otherwise = transitiveDeps
388 fixupRtsLibName "rts-1.0" = "rts"
389 fixupRtsLibName x = x
390 transitiveDepNames = map (display . packageName) transitive_dep_ids
391
392 libraryDirs = forDeps Installed.libraryDirs
393 -- The mkLibraryRelDir function is a bit of a hack.
394 -- Ideally it should be handled in the makefiles instead.
395 mkLibraryRelDir "rts" = "rts/dist/build"
396 mkLibraryRelDir "ghc" = "compiler/stage2/build"
397 mkLibraryRelDir "Cabal" = "libraries/Cabal/Cabal/dist-install/build"
398 mkLibraryRelDir l = "libraries/" ++ l ++ "/dist-install/build"
399 libraryRelDirs = map mkLibraryRelDir transitiveDepNames
400 wrappedIncludeDirs <- wrap $ forDeps Installed.includeDirs
401 wrappedLibraryDirs <- wrap libraryDirs
402
403 let variablePrefix = directory ++ '_':distdir
404 mods = map display modules
405 otherMods = map display (otherModules bi)
406 allMods = mods ++ otherMods
407 let xs = [variablePrefix ++ "_VERSION = " ++ display (pkgVersion (package pd)),
408 -- TODO: move inside withLibLBI
409 variablePrefix ++ "_COMPONENT_ID = " ++ display (localCompatPackageKey lbi),
410 -- copied from mkComponentsLocalBuildInfo
411 variablePrefix ++ "_COMPONENT_ID = " ++ display (localComponentId lbi),
412 variablePrefix ++ "_MODULES = " ++ unwords mods,
413 variablePrefix ++ "_HIDDEN_MODULES = " ++ unwords otherMods,
414 variablePrefix ++ "_SYNOPSIS =" ++ synopsis pd,
415 variablePrefix ++ "_HS_SRC_DIRS = " ++ unwords (hsSourceDirs bi),
416 variablePrefix ++ "_DEPS = " ++ unwords deps,
417 variablePrefix ++ "_DEP_IPIDS = " ++ unwords dep_ipids,
418 variablePrefix ++ "_DEP_NAMES = " ++ unwords depNames,
419 variablePrefix ++ "_DEP_COMPONENT_IDS = " ++ unwords depLibNames,
420 variablePrefix ++ "_TRANSITIVE_DEPS = " ++ unwords transitiveDeps,
421 variablePrefix ++ "_TRANSITIVE_DEP_COMPONENT_IDS = " ++ unwords transitiveDepLibNames,
422 variablePrefix ++ "_TRANSITIVE_DEP_NAMES = " ++ unwords transitiveDepNames,
423 variablePrefix ++ "_INCLUDE_DIRS = " ++ unwords (includeDirs bi),
424 variablePrefix ++ "_INCLUDES = " ++ unwords (includes bi),
425 variablePrefix ++ "_INSTALL_INCLUDES = " ++ unwords (installIncludes bi),
426 variablePrefix ++ "_EXTRA_LIBRARIES = " ++ unwords (extraLibs bi),
427 variablePrefix ++ "_EXTRA_LIBDIRS = " ++ unwords (extraLibDirs bi),
428 variablePrefix ++ "_C_SRCS = " ++ unwords (cSources bi),
429 variablePrefix ++ "_CMM_SRCS := $(addprefix cbits/,$(notdir $(wildcard " ++ directory ++ "/cbits/*.cmm)))",
430 variablePrefix ++ "_DATA_FILES = " ++ unwords (dataFiles pd),
431 -- XXX This includes things it shouldn't, like:
432 -- -odir dist-bootstrapping/build
433 variablePrefix ++ "_HC_OPTS = " ++ escape (unwords
434 ( programDefaultArgs ghcProg
435 ++ hcOptions GHC bi
436 ++ languageToFlags (compiler lbi) (defaultLanguage bi)
437 ++ extensionsToFlags (compiler lbi) (usedExtensions bi)
438 ++ programOverrideArgs ghcProg)),
439 variablePrefix ++ "_CC_OPTS = " ++ unwords (ccOptions bi),
440 variablePrefix ++ "_CPP_OPTS = " ++ unwords (cppOptions bi),
441 variablePrefix ++ "_LD_OPTS = " ++ unwords (ldOptions bi),
442 variablePrefix ++ "_DEP_INCLUDE_DIRS_SINGLE_QUOTED = " ++ unwords wrappedIncludeDirs,
443 variablePrefix ++ "_DEP_CC_OPTS = " ++ unwords (forDeps Installed.ccOptions),
444 variablePrefix ++ "_DEP_LIB_DIRS_SINGLE_QUOTED = " ++ unwords wrappedLibraryDirs,
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_EXTRA_LIBS = " ++ unwords (forDeps Installed.extraLibraries),
449 variablePrefix ++ "_DEP_LD_OPTS = " ++ unwords (forDeps Installed.ldOptions),
450 variablePrefix ++ "_BUILD_GHCI_LIB = " ++ boolToYesNo (withGHCiLib lbi),
451 "",
452 -- Sometimes we need to modify the automatically-generated package-data.mk
453 -- bindings in a special way for the GHC build system, so allow that here:
454 "$(eval $(" ++ directory ++ "_PACKAGE_MAGIC))"
455 ]
456 writeFile (distdir ++ "/package-data.mk") $ unlines xs
457
458 writeFileUtf8 (distdir ++ "/haddock-prologue.txt") $
459 if null (description pd) then synopsis pd
460 else description pd
461 unless (null dll0Modules) $
462 do let dll0Mods = words dll0Modules
463 dllMods = allMods \\ dll0Mods
464 dllModSets = map unwords [dll0Mods, dllMods]
465 writeFile (distdir ++ "/dll-split") $ unlines dllModSets
466 where
467 escape = foldr (\c xs -> if c == '#' then '\\':'#':xs else c:xs) []
468 wrap = mapM wrap1
469 wrap1 s
470 | null s = die ["Wrapping empty value"]
471 | '\'' `elem` s = die ["Single quote in value to be wrapped:", s]
472 -- We want to be able to assume things like <space><quote> is the
473 -- start of a value, so check there are no spaces in confusing
474 -- positions
475 | head s == ' ' = die ["Leading space in value to be wrapped:", s]
476 | last s == ' ' = die ["Trailing space in value to be wrapped:", s]
477 | otherwise = return ("\'" ++ s ++ "\'")
478 mkSearchPath = intercalate [searchPathSeparator]
479 boolToYesNo True = "YES"
480 boolToYesNo False = "NO"
481
482 -- | Version of 'writeFile' that always uses UTF8 encoding
483 writeFileUtf8 f txt = withFile f WriteMode $ \hdl -> do
484 hSetEncoding hdl utf8
485 hPutStr hdl txt