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