utils/ghc-cabal/ghc-cabal.hs

   1
   2 module Main (main) where
   3
   4 import Distribution.Compat.Exception
   5 import qualified Distribution.ModuleName as ModuleName
   6 import Distribution.PackageDescription
   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.Utils (defaultPackageDesc, withTempFile)
  14 import Distribution.Simple.Build (writeAutogenFiles)
  15 import Distribution.Simple.Register (writeInstalledConfig)
  16 import Distribution.Simple.PackageIndex
  17 import Distribution.Text
  18 import Distribution.Verbosity
  19 import qualified Distribution.InstalledPackageInfo as Installed
  20          ( InstalledPackageInfo_(..) )
  21 import qualified Distribution.Simple.PackageIndex as PackageIndex
  22          ( topologicalOrder, lookupPackageName, insert )
  23
  24 import Control.Exception
  25 import Control.Monad
  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 args <- getArgs
  35           case args of
  36               "haddock" : distDir : dir : args' ->
  37                   runHaddock distDir dir args'
  38               "install" : ghcpkg : ghcpkgconfig : directory : distDir
  39                         : myDestDir : myPrefix : myLibdir : myDocdir : args' ->
  40                   doInstall ghcpkg ghcpkgconfig directory distDir
  41                             myDestDir myPrefix myLibdir myDocdir args'
  42               "configure" : args' -> case break (== "--") args' of
  43                    (config_args, "--" : distdir : directories) ->
  44                        mapM_ (generate config_args distdir) directories
  45                    _ -> die syntax_error
  46               _ -> die syntax_error
  47
  48 syntax_error :: [String]
  49 syntax_error =
  50     ["syntax: ghc-cabal configure <configure-args> -- <distdir> <directory>...",
  51      "        ghc-cabal install <ghc-pkg> <directory> <distdir> <destdir> <prefix> <args>...",
  52      "        ghc-cabal haddock <distdir> <directory> <args>..."]
  53
  54 die :: [String] -> IO ()
  55 die errs = do mapM_ (hPutStrLn stderr) errs
  56               exitWith (ExitFailure 1)
  57
  58 -- XXX Should use bracket
  59 withCurrentDirectory :: FilePath -> IO a -> IO a
  60 withCurrentDirectory directory io
  61  = do curDirectory <- getCurrentDirectory
  62       setCurrentDirectory directory
  63       r <- io
  64       setCurrentDirectory curDirectory
  65       return r
  66
  67 -- We need to use the autoconfUserHooks, as the packages that use
  68 -- configure can create a .buildinfo file, and we need any info that
  69 -- ends up in it.
  70 userHooks :: UserHooks
  71 userHooks = autoconfUserHooks
  72
  73 runHaddock :: FilePath -> FilePath -> [String] -> IO ()
  74 runHaddock distdir directory args
  75  = withCurrentDirectory directory
  76  $ defaultMainWithHooksArgs hooks ("haddock" : "--builddir" : distdir : args)
  77     where
  78       hooks = userHooks {
  79                   haddockHook = modHook (haddockHook userHooks)
  80               }
  81       modHook f pd lbi us flags
  82        | packageName pd == PackageName "ghc-prim"
  83           = let pd' = case library pd of
  84                       Just lib ->
  85                           let ghcPrim = fromJust (simpleParse "GHC.Prim")
  86                               ems = filter (ghcPrim /=)
  87                                            (exposedModules lib)
  88                               lib' = lib { exposedModules = ems }
  89                           in pd { library = Just lib' }
  90                       Nothing ->
  91                           error "Expected a library, but none found"
  92                 pc = withPrograms lbi
  93                 pc' = userSpecifyArgs "haddock"
  94                           ["dist-install/build/autogen/GHC/Prim.hs"] pc
  95                 lbi' = lbi { withPrograms = pc' }
  96             in f pd' lbi' us flags
  97        | otherwise
  98           = f pd lbi us flags
  99
 100 doInstall :: FilePath -> FilePath -> FilePath -> FilePath -> FilePath
 101           -> FilePath -> FilePath -> FilePath -> [String] -> IO ()
 102 doInstall ghcpkg ghcpkgconf directory distDir myDestDir myPrefix myLibdir myDocdir args
 103  = withCurrentDirectory directory $ do
 104      defaultMainWithHooksArgs hooks (["copy", "--builddir", distDir]
 105                                      ++ (if null myDestDir then []
 106                                            else ["--destdir", myDestDir])
 107                                      ++ args)
 108      defaultMainWithHooksArgs hooks ("register" : "--builddir" : distDir : args)
 109     where
 110       hooks = userHooks {
 111                   copyHook = modHook (copyHook userHooks),
 112                   regHook  = modHook (regHook userHooks)
 113               }
 114
 115       modHook f pd lbi us flags
 116               = let
 117                     pd'
 118                      | packageName pd == PackageName "ghc-prim" =
 119                         case library pd of
 120                         Just lib ->
 121                             let ghcPrim = fromJust (simpleParse "GHC.Prim")
 122                                 ems = filter (ghcPrim /=) (exposedModules lib)
 123                                 lib' = lib { exposedModules = ems }
 124                             in pd { library = Just lib' }
 125                         Nothing ->
 126                             error "Expected a library, but none found"
 127                      | otherwise = pd
 128                     idts = installDirTemplates lbi
 129                     idts' = idts { prefix    = toPathTemplate myPrefix,
 130                                    libdir    = toPathTemplate myLibdir,
 131                                    libsubdir = toPathTemplate "$pkgid",
 132                                    docdir    = toPathTemplate (myDocdir </> "$pkgid"),
 133                                    htmldir   = toPathTemplate "$docdir" }
 134                     progs = withPrograms lbi
 135                     prog = ConfiguredProgram {
 136                                programId = programName ghcPkgProgram,
 137                                programVersion = Nothing,
 138                                programArgs = ["--global-conf", ghcpkgconf]
 139                                              ++ if not (null myDestDir)
 140                                                 then ["--force"]
 141                                                 else [],
 142                                programLocation = UserSpecified ghcpkg
 143                            }
 144                     progs' = updateProgram prog progs
 145                     lbi' = lbi {
 146                                    installDirTemplates = idts',
 147                                    withPrograms = progs'
 148                                }
 149                 in f pd' lbi' us flags
 150
 151 generate :: [String] -> FilePath -> FilePath -> IO ()
 152 generate config_args distdir directory
 153  = withCurrentDirectory directory
 154  $ do let verbosity = normal
 155       gpdFile <- defaultPackageDesc verbosity
 156       gpd <- readPackageDescription verbosity gpdFile
 157
 158       -- XXX We shouldn't just configure with the default flags
 159       -- XXX And this, and thus the "getPersistBuildConfig distdir" below,
 160       -- aren't going to work when the deps aren't built yet
 161       withArgs (["configure", "--distdir", distdir] ++ config_args)
 162           (case buildType (flattenPackageDescription gpd) of
 163               Just Configure -> defaultMainWithHooks autoconfUserHooks
 164               _other         -> defaultMain)
 165               -- not quite right, but good enough for us
 166
 167       lbi <- getPersistBuildConfig distdir
 168       let pd0 = localPkgDescr lbi
 169
 170       -- Sigh, haskeline proper uses stuff in Setup.hs to handle whether
 171       -- or not -liconv is used. We don't use Setup.hs, so we replicate
 172       -- what it does here. We should do this better somehow.
 173       when (display (pkgName (package pd0)) == "haskeline") $
 174           case library pd0 of
 175               Nothing -> fail "Can't happen: No haskeline library"
 176               Just lib -> do
 177                   d <- getCurrentDirectory
 178                   print d
 179                   maybeSetLibiconv verbosity (libBuildInfo lib) lbi
 180
 181       hooked_bi <-
 182            if (buildType pd0 == Just Configure)
 183            then do
 184               maybe_infoFile <- defaultHookedPackageDesc
 185               case maybe_infoFile of
 186                   Nothing       -> return emptyHookedBuildInfo
 187                   Just infoFile -> readHookedBuildInfo verbosity infoFile
 188            else
 189               return emptyHookedBuildInfo
 190
 191       let pd = updatePackageDescription hooked_bi pd0
 192
 193       -- generate Paths_<pkg>.hs and cabal-macros.h
 194       writeAutogenFiles verbosity pd lbi
 195
 196       -- generate inplace-pkg-config
 197       when (isJust $ library pd) $
 198           writeInstalledConfig distdir pd lbi True Nothing
 199
 200       let
 201           libBiModules lib = (libBuildInfo lib, libModules pd)
 202           exeBiModules exe = (buildInfo exe, ModuleName.main : exeModules pd)
 203           biModuless = (maybeToList $ fmap libBiModules $ library pd)
 204                     ++ (map exeBiModules $ executables pd)
 205           buildableBiModuless = filter isBuildable biModuless
 206               where isBuildable (bi', _) = buildable bi'
 207           (bi, modules) = case buildableBiModuless of
 208                           [] -> error "No buildable component found"
 209                           [biModules] -> biModules
 210                           _ -> error ("XXX ghc-cabal can't handle " ++
 211                                       "more than one buildinfo yet")
 212           -- XXX Another Just...
 213           Just ghcProg = lookupProgram ghcProgram (withPrograms lbi)
 214
 215           dep_pkgs = PackageIndex.topologicalOrder (packageHacks (installedPkgs lbi))
 216           forDeps f = concatMap f dep_pkgs
 217
 218           -- copied from Distribution.Simple.PreProcess.ppHsc2Hs
 219           packageHacks = case compilerFlavor (compiler lbi) of
 220             GHC -> hackRtsPackage
 221             _   -> id
 222           -- We don't link in the actual Haskell libraries of our
 223           -- dependencies, so the -u flags in the ldOptions of the rts
 224           -- package mean linking fails on OS X (it's ld is a tad
 225           -- stricter than gnu ld). Thus we remove the ldOptions for
 226           -- GHC's rts package:
 227           hackRtsPackage index =
 228             case PackageIndex.lookupPackageName index (PackageName "rts") of
 229               [rts] -> PackageIndex.insert rts { Installed.ldOptions = [] } index
 230               _ -> error "No (or multiple) ghc rts package is registered!!"
 231
 232       let variablePrefix = directory ++ '_':distdir
 233       let xs = [variablePrefix ++ "_VERSION = " ++ display (pkgVersion (package pd)),
 234                 variablePrefix ++ "_MODULES = " ++ unwords (map display modules),
 235                 variablePrefix ++ "_HS_SRC_DIRS = " ++ unwords (hsSourceDirs bi),
 236                 variablePrefix ++ "_DEPS = " ++ unwords (map display (packageDeps lbi)),
 237                 variablePrefix ++ "_DEP_NAMES = " ++ unwords (map (display . packageName) (packageDeps lbi)),
 238                 variablePrefix ++ "_INCLUDE_DIRS = " ++ unwords (includeDirs bi),
 239                 variablePrefix ++ "_INCLUDES = " ++ unwords (includes bi),
 240                 variablePrefix ++ "_INSTALL_INCLUDES = " ++ unwords (installIncludes bi),
 241                 variablePrefix ++ "_EXTRA_LIBRARIES = " ++ unwords (extraLibs bi),
 242                 variablePrefix ++ "_EXTRA_LIBDIRS = " ++ unwords (extraLibDirs bi),
 243                 variablePrefix ++ "_C_SRCS  = " ++ unwords (cSources bi),
 244                 -- XXX This includes things it shouldn't, like:
 245                 -- -odir dist-bootstrapping/build
 246                 variablePrefix ++ "_HC_OPTS = " ++ escape (unwords
 247                         (programArgs ghcProg
 248                         ++ hcOptions GHC bi
 249                         ++ extensionsToFlags (compiler lbi) (extensions bi))),
 250                 variablePrefix ++ "_CC_OPTS = " ++ unwords (ccOptions bi),
 251                 variablePrefix ++ "_CPP_OPTS = " ++ unwords (cppOptions bi),
 252                 variablePrefix ++ "_LD_OPTS = " ++ unwords (ldOptions bi),
 253                 variablePrefix ++ "_DEP_INCLUDE_DIRS = " ++ unwords (forDeps Installed.includeDirs),
 254                 variablePrefix ++ "_DEP_CC_OPTS = "    ++ unwords (forDeps Installed.ccOptions),
 255                 variablePrefix ++ "_DEP_LIB_DIRS = "   ++ unwords (forDeps Installed.libraryDirs),
 256                 variablePrefix ++ "_DEP_EXTRA_LIBS = " ++ unwords (forDeps Installed.extraLibraries),
 257                 variablePrefix ++ "_DEP_LD_OPTS = "    ++ unwords (forDeps Installed.ldOptions)]
 258       writeFile (distdir ++ "/package-data.mk") $ unlines xs
 259   where
 260      escape = foldr (\c xs -> if c == '#' then '\\':'#':xs else c:xs) []
 261
 262 ----------------------------------------------------------------------
 263 -- haskeline-specific hacks
 264
 265 -- Sigh, haskeline proper uses stuff in Setup.hs to handle whether
 266 -- or not -liconv is used. We don't use Setup.hs, so we replicate
 267 -- what it does here. We should do this better somehow.
 268
 269 -- Test whether compiling a c program that links against libiconv needs -liconv.
 270 maybeSetLibiconv :: Verbosity -> BuildInfo -> LocalBuildInfo -> IO ()
 271 maybeSetLibiconv verb bi lbi = do
 272     let biWithIconv = addIconv bi
 273     worksWithout <- tryCompile iconv_prog bi lbi verb
 274     if worksWithout
 275         then writeBuildInfo ""
 276         else do
 277     worksWith <- tryCompile iconv_prog biWithIconv lbi verb
 278     if worksWith
 279         then do
 280             writeBuildInfo "iconv"
 281         else fail "Unable to link against the iconv library."
 282   where
 283     -- Cabal (at least 1.6.0.1) won't parse an empty buildinfo file.
 284     writeBuildInfo libs = writeFile "haskeline.buildinfo"
 285                             $ unlines ["extra-libraries: " ++ libs]
 286
 287 tryCompile :: String -> BuildInfo -> LocalBuildInfo -> Verbosity -> IO Bool
 288 tryCompile program bi lbi verb = flip catchIO processException $ flip catchExit processExit $ do
 289     tempDir <- getTemporaryDirectory
 290     withTempFile tempDir ".c" $ \fname h -> do
 291         hPutStr h program
 292         hClose h
 293         -- TODO take verbosity from the args.
 294         rawSystemProgramStdoutConf verb gccProgram (withPrograms lbi) (fname : args)
 295         return True
 296   where
 297     processException :: IOException -> IO Bool
 298     processException _ = return False
 299     processExit = return . (==ExitSuccess)
 300     -- Mimicing Distribution.Simple.Configure
 301     deps = topologicalOrder (installedPkgs lbi)
 302     args = concat
 303                   [ ccOptions bi
 304                   , cppOptions bi
 305                   , ldOptions bi
 306                   -- --extra-include-dirs and --extra-lib-dirs are included
 307                   -- in the below fields.
 308                   -- Also sometimes a dependency like rts points to a nonstandard
 309                   -- include/lib directory where iconv can be found.
 310                   , map ("-I" ++) (includeDirs bi ++ concatMap Installed.includeDirs deps)
 311                   , map ("-L" ++) (extraLibDirs bi ++ concatMap Installed.libraryDirs deps)
 312                   , map ("-l" ++) (extraLibs bi)
 313                   ]
 314
 315 addIconv :: BuildInfo -> BuildInfo
 316 addIconv bi = bi {extraLibs = "iconv" : extraLibs bi}
 317
 318 iconv_prog :: String
 319 iconv_prog = unlines $
 320     [ "#include <iconv.h>"
 321     , "int main(void) {"
 322     , "    iconv_t t = iconv_open(\"UTF-8\", \"UTF-8\");"
 323     , "    return 0;"
 324     , "}"
 325     ]
 326