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
 202                                (distdir </> "inplace-pkg-config")
 203
 204       let
 205           libBiModules lib = (libBuildInfo lib, libModules lib)
 206           exeBiModules exe = (buildInfo exe, ModuleName.main : exeModules exe)
 207           biModuless = (maybeToList $ fmap libBiModules $ library pd)
 208                     ++ (map exeBiModules $ executables pd)
 209           buildableBiModuless = filter isBuildable biModuless
 210               where isBuildable (bi', _) = buildable bi'
 211           (bi, modules) = case buildableBiModuless of
 212                           [] -> error "No buildable component found"
 213                           [biModules] -> biModules
 214                           _ -> error ("XXX ghc-cabal can't handle " ++
 215                                       "more than one buildinfo yet")
 216           -- XXX Another Just...
 217           Just ghcProg = lookupProgram ghcProgram (withPrograms lbi)
 218
 219           dep_pkgs = PackageIndex.topologicalOrder (packageHacks (installedPkgs lbi))
 220           forDeps f = concatMap f dep_pkgs
 221
 222           -- copied from Distribution.Simple.PreProcess.ppHsc2Hs
 223           packageHacks = case compilerFlavor (compiler lbi) of
 224             GHC -> hackRtsPackage
 225             _   -> id
 226           -- We don't link in the actual Haskell libraries of our
 227           -- dependencies, so the -u flags in the ldOptions of the rts
 228           -- package mean linking fails on OS X (it's ld is a tad
 229           -- stricter than gnu ld). Thus we remove the ldOptions for
 230           -- GHC's rts package:
 231           hackRtsPackage index =
 232             case PackageIndex.lookupPackageName index (PackageName "rts") of
 233               [rts] -> PackageIndex.insert rts { Installed.ldOptions = [] } index
 234               _ -> error "No (or multiple) ghc rts package is registered!!"
 235
 236       let variablePrefix = directory ++ '_':distdir
 237       let xs = [variablePrefix ++ "_VERSION = " ++ display (pkgVersion (package pd)),
 238                 variablePrefix ++ "_MODULES = " ++ unwords (map display modules),
 239                 variablePrefix ++ "_HS_SRC_DIRS = " ++ unwords (hsSourceDirs bi),
 240                 variablePrefix ++ "_DEPS = " ++ unwords (map display (externalPackageDeps lbi)),
 241                 variablePrefix ++ "_DEP_NAMES = " ++ unwords (map (display . packageName) (externalPackageDeps lbi)),
 242                 variablePrefix ++ "_INCLUDE_DIRS = " ++ unwords (includeDirs bi),
 243                 variablePrefix ++ "_INCLUDES = " ++ unwords (includes bi),
 244                 variablePrefix ++ "_INSTALL_INCLUDES = " ++ unwords (installIncludes bi),
 245                 variablePrefix ++ "_EXTRA_LIBRARIES = " ++ unwords (extraLibs bi),
 246                 variablePrefix ++ "_EXTRA_LIBDIRS = " ++ unwords (extraLibDirs bi),
 247                 variablePrefix ++ "_C_SRCS  = " ++ unwords (cSources bi),
 248                 -- XXX This includes things it shouldn't, like:
 249                 -- -odir dist-bootstrapping/build
 250                 variablePrefix ++ "_HC_OPTS = " ++ escape (unwords
 251                         (programArgs ghcProg
 252                         ++ hcOptions GHC bi
 253                         ++ extensionsToFlags (compiler lbi) (extensions bi))),
 254                 variablePrefix ++ "_CC_OPTS = " ++ unwords (ccOptions bi),
 255                 variablePrefix ++ "_CPP_OPTS = " ++ unwords (cppOptions bi),
 256                 variablePrefix ++ "_LD_OPTS = " ++ unwords (ldOptions bi),
 257                 variablePrefix ++ "_DEP_INCLUDE_DIRS = " ++ unwords (forDeps Installed.includeDirs),
 258                 variablePrefix ++ "_DEP_CC_OPTS = "    ++ unwords (forDeps Installed.ccOptions),
 259                 variablePrefix ++ "_DEP_LIB_DIRS = "   ++ unwords (forDeps Installed.libraryDirs),
 260                 variablePrefix ++ "_DEP_EXTRA_LIBS = " ++ unwords (forDeps Installed.extraLibraries),
 261                 variablePrefix ++ "_DEP_LD_OPTS = "    ++ unwords (forDeps Installed.ldOptions)]
 262       writeFile (distdir ++ "/package-data.mk") $ unlines xs
 263   where
 264      escape = foldr (\c xs -> if c == '#' then '\\':'#':xs else c:xs) []
 265
 266 ----------------------------------------------------------------------
 267 -- haskeline-specific hacks
 268
 269 -- Sigh, haskeline proper uses stuff in Setup.hs to handle whether
 270 -- or not -liconv is used. We don't use Setup.hs, so we replicate
 271 -- what it does here. We should do this better somehow.
 272
 273 -- Test whether compiling a c program that links against libiconv needs -liconv.
 274 maybeSetLibiconv :: Verbosity -> BuildInfo -> LocalBuildInfo -> IO ()
 275 maybeSetLibiconv verb bi lbi = do
 276     let biWithIconv = addIconv bi
 277     worksWithout <- tryCompile iconv_prog bi lbi verb
 278     if worksWithout
 279         then writeBuildInfo ""
 280         else do
 281     worksWith <- tryCompile iconv_prog biWithIconv lbi verb
 282     if worksWith
 283         then do
 284             writeBuildInfo "iconv"
 285         else fail "Unable to link against the iconv library."
 286   where
 287     -- Cabal (at least 1.6.0.1) won't parse an empty buildinfo file.
 288     writeBuildInfo libs = writeFile "haskeline.buildinfo"
 289                             $ unlines ["extra-libraries: " ++ libs]
 290
 291 tryCompile :: String -> BuildInfo -> LocalBuildInfo -> Verbosity -> IO Bool
 292 tryCompile program bi lbi verb = flip catchIO processException $ flip catchExit processExit $ do
 293     tempDir <- getTemporaryDirectory
 294     withTempFile tempDir ".c" $ \fname h -> do
 295         hPutStr h program
 296         hClose h
 297         -- TODO take verbosity from the args.
 298         rawSystemProgramStdoutConf verb gccProgram (withPrograms lbi) (fname : args)
 299         return True
 300   where
 301     processException :: IOException -> IO Bool
 302     processException _ = return False
 303     processExit = return . (==ExitSuccess)
 304     -- Mimicing Distribution.Simple.Configure
 305     deps = topologicalOrder (installedPkgs lbi)
 306     args = concat
 307                   [ ccOptions bi
 308                   , cppOptions bi
 309                   , ldOptions bi
 310                   -- --extra-include-dirs and --extra-lib-dirs are included
 311                   -- in the below fields.
 312                   -- Also sometimes a dependency like rts points to a nonstandard
 313                   -- include/lib directory where iconv can be found.
 314                   , map ("-I" ++) (includeDirs bi ++ concatMap Installed.includeDirs deps)
 315                   , map ("-L" ++) (extraLibDirs bi ++ concatMap Installed.libraryDirs deps)
 316                   , map ("-l" ++) (extraLibs bi)
 317                   ]
 318
 319 addIconv :: BuildInfo -> BuildInfo
 320 addIconv bi = bi {extraLibs = "iconv" : extraLibs bi}
 321
 322 iconv_prog :: String
 323 iconv_prog = unlines $
 324     [ "#include <iconv.h>"
 325     , "int main(void) {"
 326     , "    iconv_t t = iconv_open(\"UTF-8\", \"UTF-8\");"
 327     , "    return 0;"
 328     , "}"
 329     ]
 330