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 = modHook (copyHook userHooks),
 113                   regHook  = modHook (regHook userHooks)
 114               }
 115
 116       modHook f pd lbi us flags
 117               = let
 118                     pd'
 119                      | packageName pd == PackageName "ghc-prim" =
 120                         case library pd of
 121                         Just lib ->
 122                             let ghcPrim = fromJust (simpleParse "GHC.Prim")
 123                                 ems = filter (ghcPrim /=) (exposedModules lib)
 124                                 lib' = lib { exposedModules = ems }
 125                             in pd { library = Just lib' }
 126                         Nothing ->
 127                             error "Expected a library, but none found"
 128                      | otherwise = pd
 129                     idts = installDirTemplates lbi
 130                     idts' = idts { prefix    = toPathTemplate myPrefix,
 131                                    libdir    = toPathTemplate myLibdir,
 132                                    libsubdir = toPathTemplate "$pkgid",
 133                                    docdir    = toPathTemplate (myDocdir </> "$pkgid"),
 134                                    htmldir   = toPathTemplate "$docdir" }
 135                     progs = withPrograms lbi
 136                     prog = ConfiguredProgram {
 137                                programId = programName ghcPkgProgram,
 138                                programVersion = Nothing,
 139                                programArgs = ["--global-conf", ghcpkgconf]
 140                                              ++ if not (null myDestDir)
 141                                                 then ["--force"]
 142                                                 else [],
 143                                programLocation = UserSpecified ghcpkg
 144                            }
 145                     progs' = updateProgram prog progs
 146                     lbi' = lbi {
 147                                    installDirTemplates = idts',
 148                                    withPrograms = progs'
 149                                }
 150                 in f pd' lbi' us flags
 151
 152 generate :: [String] -> FilePath -> FilePath -> IO ()
 153 generate config_args distdir directory
 154  = withCurrentDirectory directory
 155  $ do let verbosity = normal
 156       gpdFile <- defaultPackageDesc verbosity
 157       gpd <- readPackageDescription verbosity gpdFile
 158
 159       -- XXX We shouldn't just configure with the default flags
 160       -- XXX And this, and thus the "getPersistBuildConfig distdir" below,
 161       -- aren't going to work when the deps aren't built yet
 162       withArgs (["configure", "--distdir", distdir] ++ config_args)
 163           (case buildType (flattenPackageDescription gpd) of
 164               Just Configure -> defaultMainWithHooks autoconfUserHooks
 165               _other         -> defaultMain)
 166               -- not quite right, but good enough for us
 167
 168       lbi <- getPersistBuildConfig distdir
 169       let pd0 = localPkgDescr lbi
 170
 171       -- Sigh, haskeline proper uses stuff in Setup.hs to handle whether
 172       -- or not -liconv is used. We don't use Setup.hs, so we replicate
 173       -- what it does here. We should do this better somehow.
 174       when ((display (pkgName (package pd0)) == "haskeline") &&
 175             (buildOS /= Windows)) $
 176           case library pd0 of
 177               Nothing -> fail "Can't happen: No haskeline library"
 178               Just lib -> do
 179                   d <- getCurrentDirectory
 180                   print d
 181                   maybeSetLibiconv verbosity (libBuildInfo lib) lbi
 182
 183       hooked_bi <-
 184            if (buildType pd0 == Just Configure) || (buildType pd0 == Just Custom)
 185            then do
 186               maybe_infoFile <- defaultHookedPackageDesc
 187               case maybe_infoFile of
 188                   Nothing       -> return emptyHookedBuildInfo
 189                   Just infoFile -> readHookedBuildInfo verbosity infoFile
 190            else
 191               return emptyHookedBuildInfo
 192
 193       let pd = updatePackageDescription hooked_bi pd0
 194
 195       -- generate Paths_<pkg>.hs and cabal-macros.h
 196       writeAutogenFiles verbosity pd lbi
 197
 198       -- generate inplace-pkg-config
 199       when (isJust $ library pd) $
 200           writeInstalledConfig distdir pd lbi True Nothing
 201
 202       let
 203           libBiModules lib = (libBuildInfo lib, libModules pd)
 204           exeBiModules exe = (buildInfo exe, ModuleName.main : exeModules pd)
 205           biModuless = (maybeToList $ fmap libBiModules $ library pd)
 206                     ++ (map exeBiModules $ executables pd)
 207           buildableBiModuless = filter isBuildable biModuless
 208               where isBuildable (bi', _) = buildable bi'
 209           (bi, modules) = case buildableBiModuless of
 210                           [] -> error "No buildable component found"
 211                           [biModules] -> biModules
 212                           _ -> error ("XXX ghc-cabal can't handle " ++
 213                                       "more than one buildinfo yet")
 214           -- XXX Another Just...
 215           Just ghcProg = lookupProgram ghcProgram (withPrograms lbi)
 216
 217           dep_pkgs = PackageIndex.topologicalOrder (packageHacks (installedPkgs lbi))
 218           forDeps f = concatMap f dep_pkgs
 219
 220           -- copied from Distribution.Simple.PreProcess.ppHsc2Hs
 221           packageHacks = case compilerFlavor (compiler lbi) of
 222             GHC -> hackRtsPackage
 223             _   -> id
 224           -- We don't link in the actual Haskell libraries of our
 225           -- dependencies, so the -u flags in the ldOptions of the rts
 226           -- package mean linking fails on OS X (it's ld is a tad
 227           -- stricter than gnu ld). Thus we remove the ldOptions for
 228           -- GHC's rts package:
 229           hackRtsPackage index =
 230             case PackageIndex.lookupPackageName index (PackageName "rts") of
 231               [rts] -> PackageIndex.insert rts { Installed.ldOptions = [] } index
 232               _ -> error "No (or multiple) ghc rts package is registered!!"
 233
 234       let variablePrefix = directory ++ '_':distdir
 235       let xs = [variablePrefix ++ "_VERSION = " ++ display (pkgVersion (package pd)),
 236                 variablePrefix ++ "_MODULES = " ++ unwords (map display modules),
 237                 variablePrefix ++ "_HS_SRC_DIRS = " ++ unwords (hsSourceDirs bi),
 238                 variablePrefix ++ "_DEPS = " ++ unwords (map display (packageDeps lbi)),
 239                 variablePrefix ++ "_DEP_NAMES = " ++ unwords (map (display . packageName) (packageDeps lbi)),
 240                 variablePrefix ++ "_INCLUDE_DIRS = " ++ unwords (includeDirs bi),
 241                 variablePrefix ++ "_INCLUDES = " ++ unwords (includes bi),
 242                 variablePrefix ++ "_INSTALL_INCLUDES = " ++ unwords (installIncludes bi),
 243                 variablePrefix ++ "_EXTRA_LIBRARIES = " ++ unwords (extraLibs bi),
 244                 variablePrefix ++ "_EXTRA_LIBDIRS = " ++ unwords (extraLibDirs bi),
 245                 variablePrefix ++ "_C_SRCS  = " ++ unwords (cSources bi),
 246                 -- XXX This includes things it shouldn't, like:
 247                 -- -odir dist-bootstrapping/build
 248                 variablePrefix ++ "_HC_OPTS = " ++ escape (unwords
 249                         (programArgs ghcProg
 250                         ++ hcOptions GHC bi
 251                         ++ extensionsToFlags (compiler lbi) (extensions bi))),
 252                 variablePrefix ++ "_CC_OPTS = " ++ unwords (ccOptions bi),
 253                 variablePrefix ++ "_CPP_OPTS = " ++ unwords (cppOptions bi),
 254                 variablePrefix ++ "_LD_OPTS = " ++ unwords (ldOptions bi),
 255                 variablePrefix ++ "_DEP_INCLUDE_DIRS = " ++ unwords (forDeps Installed.includeDirs),
 256                 variablePrefix ++ "_DEP_CC_OPTS = "    ++ unwords (forDeps Installed.ccOptions),
 257                 variablePrefix ++ "_DEP_LIB_DIRS = "   ++ unwords (forDeps Installed.libraryDirs),
 258                 variablePrefix ++ "_DEP_EXTRA_LIBS = " ++ unwords (forDeps Installed.extraLibraries),
 259                 variablePrefix ++ "_DEP_LD_OPTS = "    ++ unwords (forDeps Installed.ldOptions)]
 260       writeFile (distdir ++ "/package-data.mk") $ unlines xs
 261   where
 262      escape = foldr (\c xs -> if c == '#' then '\\':'#':xs else c:xs) []
 263
 264 ----------------------------------------------------------------------
 265 -- haskeline-specific hacks
 266
 267 -- Sigh, haskeline proper uses stuff in Setup.hs to handle whether
 268 -- or not -liconv is used. We don't use Setup.hs, so we replicate
 269 -- what it does here. We should do this better somehow.
 270
 271 -- Test whether compiling a c program that links against libiconv needs -liconv.
 272 maybeSetLibiconv :: Verbosity -> BuildInfo -> LocalBuildInfo -> IO ()
 273 maybeSetLibiconv verb bi lbi = do
 274     let biWithIconv = addIconv bi
 275     worksWithout <- tryCompile iconv_prog bi lbi verb
 276     if worksWithout
 277         then writeBuildInfo ""
 278         else do
 279     worksWith <- tryCompile iconv_prog biWithIconv lbi verb
 280     if worksWith
 281         then do
 282             writeBuildInfo "iconv"
 283         else fail "Unable to link against the iconv library."
 284   where
 285     -- Cabal (at least 1.6.0.1) won't parse an empty buildinfo file.
 286     writeBuildInfo libs = writeFile "haskeline.buildinfo"
 287                             $ unlines ["extra-libraries: " ++ libs]
 288
 289 tryCompile :: String -> BuildInfo -> LocalBuildInfo -> Verbosity -> IO Bool
 290 tryCompile program bi lbi verb = flip catchIO processException $ flip catchExit processExit $ do
 291     tempDir <- getTemporaryDirectory
 292     withTempFile tempDir ".c" $ \fname h -> do
 293         hPutStr h program
 294         hClose h
 295         -- TODO take verbosity from the args.
 296         rawSystemProgramStdoutConf verb gccProgram (withPrograms lbi) (fname : args)
 297         return True
 298   where
 299     processException :: IOException -> IO Bool
 300     processException _ = return False
 301     processExit = return . (==ExitSuccess)
 302     -- Mimicing Distribution.Simple.Configure
 303     deps = topologicalOrder (installedPkgs lbi)
 304     args = concat
 305                   [ ccOptions bi
 306                   , cppOptions bi
 307                   , ldOptions bi
 308                   -- --extra-include-dirs and --extra-lib-dirs are included
 309                   -- in the below fields.
 310                   -- Also sometimes a dependency like rts points to a nonstandard
 311                   -- include/lib directory where iconv can be found.
 312                   , map ("-I" ++) (includeDirs bi ++ concatMap Installed.includeDirs deps)
 313                   , map ("-L" ++) (extraLibDirs bi ++ concatMap Installed.libraryDirs deps)
 314                   , map ("-l" ++) (extraLibs bi)
 315                   ]
 316
 317 addIconv :: BuildInfo -> BuildInfo
 318 addIconv bi = bi {extraLibs = "iconv" : extraLibs bi}
 319
 320 iconv_prog :: String
 321 iconv_prog = unlines $
 322     [ "#include <iconv.h>"
 323     , "int main(void) {"
 324     , "    iconv_t t = iconv_open(\"UTF-8\", \"UTF-8\");"
 325     , "    return 0;"
 326     , "}"
 327     ]
 328