Main.hs 18.8 KB
Newer Older
Ian Lynagh's avatar
Ian Lynagh committed
1 2 3 4 5

module Main (main) where

import qualified Distribution.ModuleName as ModuleName
import Distribution.PackageDescription
6
import Distribution.PackageDescription.Check hiding (doesFileExist)
Ian Lynagh's avatar
Ian Lynagh committed
7 8 9 10 11 12
import Distribution.PackageDescription.Configuration
import Distribution.PackageDescription.Parse
import Distribution.Simple
import Distribution.Simple.Configure
import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.Program
Ian Lynagh's avatar
Ian Lynagh committed
13
import Distribution.Simple.Program.HcPkg
14
import Distribution.Simple.Utils (defaultPackageDesc, writeFileAtomic, toUTF8)
Ian Lynagh's avatar
Ian Lynagh committed
15
import Distribution.Simple.Build (writeAutogenFiles)
Ian Lynagh's avatar
Ian Lynagh committed
16
import Distribution.Simple.Register
Ian Lynagh's avatar
Ian Lynagh committed
17 18 19 20 21
import Distribution.Text
import Distribution.Verbosity
import qualified Distribution.InstalledPackageInfo as Installed
import qualified Distribution.Simple.PackageIndex as PackageIndex

pcapriotti's avatar
pcapriotti committed
22
import Control.Monad
23
import Data.List
Ian Lynagh's avatar
Ian Lynagh committed
24 25 26 27 28 29 30 31
import Data.Maybe
import System.IO
import System.Directory
import System.Environment
import System.Exit
import System.FilePath

main :: IO ()
32 33
main = do hSetBuffering stdout LineBuffering
          args <- getArgs
Ian Lynagh's avatar
Ian Lynagh committed
34
          case args of
35 36
              "hscolour" : distDir : dir : args' ->
                  runHsColour distDir dir args'
37 38
              "check" : dir : [] ->
                  doCheck dir
39
              "install" : ghc : ghcpkg : strip : topdir : directory : distDir
40 41
                        : myDestDir : myPrefix : myLibdir : myDocdir
                        : relocatableBuild : args' ->
42
                  doInstall ghc ghcpkg strip topdir directory distDir
43 44
                            myDestDir myPrefix myLibdir myDocdir
                            relocatableBuild args'
Ian Lynagh's avatar
Ian Lynagh committed
45 46 47 48
              "configure" : args' -> case break (== "--") args' of
                   (config_args, "--" : distdir : directories) ->
                       mapM_ (generate config_args distdir) directories
                   _ -> die syntax_error
49 50
              "sdist" : dir : distDir : [] ->
                  doSdist dir distDir
51 52
              ["--version"] ->
                  defaultMainArgs ["--version"]
Ian Lynagh's avatar
Ian Lynagh committed
53 54 55 56 57 58
              _ -> die syntax_error

syntax_error :: [String]
syntax_error =
    ["syntax: ghc-cabal configure <configure-args> -- <distdir> <directory>...",
     "        ghc-cabal install <ghc-pkg> <directory> <distdir> <destdir> <prefix> <args>...",
59
     "        ghc-cabal hscolour <distdir> <directory> <args>..."]
Ian Lynagh's avatar
Ian Lynagh committed
60

61
die :: [String] -> IO a
Ian Lynagh's avatar
Ian Lynagh committed
62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79
die errs = do mapM_ (hPutStrLn stderr) errs
              exitWith (ExitFailure 1)

-- XXX Should use bracket
withCurrentDirectory :: FilePath -> IO a -> IO a
withCurrentDirectory directory io
 = do curDirectory <- getCurrentDirectory
      setCurrentDirectory directory
      r <- io
      setCurrentDirectory curDirectory
      return r

-- We need to use the autoconfUserHooks, as the packages that use
-- configure can create a .buildinfo file, and we need any info that
-- ends up in it.
userHooks :: UserHooks
userHooks = autoconfUserHooks

80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103
runDefaultMain :: IO ()
runDefaultMain
 = do let verbosity = normal
      gpdFile <- defaultPackageDesc verbosity
      gpd <- readPackageDescription verbosity gpdFile
      case buildType (flattenPackageDescription gpd) of
          Just Configure -> defaultMainWithHooks autoconfUserHooks
          -- time has a "Custom" Setup.hs, but it's actually Configure
          -- plus a "./Setup test" hook. However, Cabal is also
          -- "Custom", but doesn't have a configure script.
          Just Custom ->
              do configureExists <- doesFileExist "configure"
                 if configureExists
                     then defaultMainWithHooks autoconfUserHooks
                     else defaultMain
          -- not quite right, but good enough for us:
          _ -> defaultMain

doSdist :: FilePath -> FilePath -> IO ()
doSdist directory distDir
 = withCurrentDirectory directory
 $ withArgs (["sdist", "--builddir", distDir])
            runDefaultMain

104 105 106 107 108 109 110 111 112 113 114 115 116 117
doCheck :: FilePath -> IO ()
doCheck directory
 = withCurrentDirectory directory
 $ do let verbosity = normal
      gpdFile <- defaultPackageDesc verbosity
      gpd <- readPackageDescription verbosity gpdFile
      case partition isFailure $ checkPackage gpd Nothing of
          ([],   [])       -> return ()
          ([],   warnings) -> mapM_ print warnings
          (errs, _)        -> do mapM_ print errs
                                 exitWith (ExitFailure 1)
    where isFailure (PackageDistSuspicious {}) = False
          isFailure _ = True

118 119
runHsColour :: FilePath -> FilePath -> [String] -> IO ()
runHsColour distdir directory args
Ian Lynagh's avatar
Ian Lynagh committed
120
 = withCurrentDirectory directory
121
 $ defaultMainArgs ("hscolour" : "--builddir" : distdir : args)
Ian Lynagh's avatar
Ian Lynagh committed
122 123

doInstall :: FilePath -> FilePath -> FilePath -> FilePath -> FilePath
124 125
          -> FilePath -> FilePath -> FilePath -> FilePath -> FilePath
          -> String -> [String]
126
          -> IO ()
127
doInstall ghc ghcpkg strip topdir directory distDir
128 129
          myDestDir myPrefix myLibdir myDocdir
          relocatableBuildStr args
Ian Lynagh's avatar
Ian Lynagh committed
130
 = withCurrentDirectory directory $ do
131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150
     relocatableBuild <- case relocatableBuildStr of
                         "YES" -> return True
                         "NO"  -> return False
                         _ -> die ["Bad relocatableBuildStr: " ++
                                   show relocatableBuildStr]
     let copyArgs = ["copy", "--builddir", distDir]
                 ++ (if null myDestDir
                     then []
                     else ["--destdir", myDestDir])
                 ++ args
         regArgs = "register" : "--builddir" : distDir : args
         copyHooks = userHooks {
                         copyHook = noGhcPrimHook
                                  $ modHook False
                                  $ copyHook userHooks
                     }
         regHooks = userHooks {
                        regHook = modHook relocatableBuild
                                $ regHook userHooks
                    }
Ian Lynagh's avatar
Ian Lynagh committed
151

152 153 154
     defaultMainWithHooksArgs copyHooks copyArgs
     defaultMainWithHooksArgs regHooks  regArgs
    where
155 156
      noGhcPrimHook f pd lbi us flags
              = let pd'
Ian Lynagh's avatar
Ian Lynagh committed
157 158 159 160 161 162 163 164 165 166
                     | packageName pd == PackageName "ghc-prim" =
                        case library pd of
                        Just lib ->
                            let ghcPrim = fromJust (simpleParse "GHC.Prim")
                                ems = filter (ghcPrim /=) (exposedModules lib)
                                lib' = lib { exposedModules = ems }
                            in pd { library = Just lib' }
                        Nothing ->
                            error "Expected a library, but none found"
                     | otherwise = pd
167
                in f pd' lbi us flags
168
      modHook relocatableBuild f pd lbi us flags
Ian Lynagh's avatar
Ian Lynagh committed
169 170
       = do let verbosity = normal
                idts = installDirTemplates lbi
171 172 173 174 175 176 177 178 179 180 181 182
                idts' = idts {
                            prefix    = toPathTemplate $
                                            if relocatableBuild
                                            then "$topdir"
                                            else myPrefix,
                            libdir    = toPathTemplate $
                                            if relocatableBuild
                                            then "$topdir"
                                            else myLibdir,
                            libsubdir = toPathTemplate "$pkgid",
                            docdir    = toPathTemplate $
                                            if relocatableBuild
Ian Lynagh's avatar
Ian Lynagh committed
183
                                            then "$topdir/../doc/html/libraries/$pkgid"
184
                                            else (myDocdir </> "$pkgid"),
185 186
                            htmldir   = toPathTemplate "$docdir"
                        }
Ian Lynagh's avatar
Ian Lynagh committed
187
                progs = withPrograms lbi
188
                ghcpkgconf = topdir </> "package.conf.d"
pcapriotti's avatar
pcapriotti committed
189 190 191 192
                ghcProgram' = ghcProgram {
                    programPostConf = \_ _ -> return ["-B" ++ topdir],
                    programFindLocation = \_ -> return (Just ghc) }
                ghcPkgProgram' = ghcPkgProgram {
193
                    programPostConf = \_ _ -> return $ ["--global-package-db", ghcpkgconf]
pcapriotti's avatar
pcapriotti committed
194 195 196 197 198 199 200 201
                                                    ++ ["--force" | not (null myDestDir) ],
                    programFindLocation = \_ -> return (Just ghcpkg) }
                stripProgram' = stripProgram {
                    programFindLocation = \_ -> return (Just strip) }
                configurePrograms ps conf = foldM (flip (configureProgram verbosity)) conf ps

            progs' <- configurePrograms [ghcProgram', ghcPkgProgram', stripProgram'] progs
            let Just ghcPkgProg = lookupProgram ghcPkgProgram' progs'
Ian Lynagh's avatar
Ian Lynagh committed
202
            instInfos <- dump verbosity ghcPkgProg GlobalPackageDB
203
            let installedPkgs' = PackageIndex.fromList instInfos
Ian Lynagh's avatar
Ian Lynagh committed
204 205 206
            let mlc = libraryConfig lbi
                mlc' = case mlc of
                       Just lc ->
207 208 209
                           let cipds = componentPackageDeps lc
                               cipds' = [ (fixupPackageId instInfos ipid, pid)
                                        | (ipid,pid) <- cipds ]
Ian Lynagh's avatar
Ian Lynagh committed
210
                           in Just $ lc {
211
                                         componentPackageDeps = cipds'
Ian Lynagh's avatar
Ian Lynagh committed
212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229
                                     }
                       Nothing -> Nothing
                lbi' = lbi {
                               libraryConfig = mlc',
                               installedPkgs = installedPkgs',
                               installDirTemplates = idts',
                               withPrograms = progs'
                           }
            f pd lbi' us flags

-- The packages are built with the package ID ending in "-inplace", but
-- when they're installed they get the package hash appended. We need to
-- fix up the package deps so that they use the hash package IDs, not
-- the inplace package IDs.
fixupPackageId :: [Installed.InstalledPackageInfo]
               -> InstalledPackageId
               -> InstalledPackageId
fixupPackageId _ x@(InstalledPackageId ipi)
230
 | "builtin_" `isPrefixOf` ipi = x
Ian Lynagh's avatar
Ian Lynagh committed
231 232 233 234 235 236 237 238 239 240 241 242 243 244
fixupPackageId ipinfos (InstalledPackageId ipi)
 = case stripPrefix (reverse "-inplace") $ reverse ipi of
   Nothing ->
       error ("Installed package ID doesn't end in -inplace: " ++ show ipi)
   Just x ->
       let ipi' = reverse ('-' : x)
           f (ipinfo : ipinfos') = case Installed.installedPackageId ipinfo of
                                   y@(InstalledPackageId ipinfoid)
                                    | ipi' `isPrefixOf` ipinfoid ->
                                       y
                                   _ ->
                                       f ipinfos'
           f [] = error ("Installed package ID not registered: " ++ show ipi)
       in f ipinfos
Ian Lynagh's avatar
Ian Lynagh committed
245 246 247 248

generate :: [String] -> FilePath -> FilePath -> IO ()
generate config_args distdir directory
 = withCurrentDirectory directory
Ian Lynagh's avatar
Ian Lynagh committed
249
 $ do let verbosity = normal
Ian Lynagh's avatar
Ian Lynagh committed
250 251 252 253
      -- XXX We shouldn't just configure with the default flags
      -- XXX And this, and thus the "getPersistBuildConfig distdir" below,
      -- aren't going to work when the deps aren't built yet
      withArgs (["configure", "--distdir", distdir] ++ config_args)
254
               runDefaultMain
Ian Lynagh's avatar
Ian Lynagh committed
255 256 257 258 259

      lbi <- getPersistBuildConfig distdir
      let pd0 = localPkgDescr lbi

      hooked_bi <-
Ian Lynagh's avatar
Ian Lynagh committed
260
           if (buildType pd0 == Just Configure) || (buildType pd0 == Just Custom)
Ian Lynagh's avatar
Ian Lynagh committed
261 262 263 264 265 266 267 268 269 270 271 272 273 274
           then do
              maybe_infoFile <- defaultHookedPackageDesc
              case maybe_infoFile of
                  Nothing       -> return emptyHookedBuildInfo
                  Just infoFile -> readHookedBuildInfo verbosity infoFile
           else
              return emptyHookedBuildInfo

      let pd = updatePackageDescription hooked_bi pd0

      -- generate Paths_<pkg>.hs and cabal-macros.h
      writeAutogenFiles verbosity pd lbi

      -- generate inplace-pkg-config
Ian Lynagh's avatar
Ian Lynagh committed
275 276 277 278
      case (library pd, libraryConfig lbi) of
          (Nothing, Nothing) -> return ()
          (Just lib, Just clbi) -> do
              cwd <- getCurrentDirectory
279
              let ipid = InstalledPackageId (display (packageId pd) ++ "-inplace")
Ian Lynagh's avatar
Ian Lynagh committed
280 281
              let installedPkgInfo = inplaceInstalledPackageInfo cwd distdir
                                         pd lib lbi clbi
282 283
                  final_ipi = installedPkgInfo {
                                  Installed.installedPackageId = ipid,
284
                                  Installed.haddockHTMLs = []
285
                              }
286
                  content = Installed.showInstalledPackageInfo final_ipi ++ "\n"
287
              writeFileAtomic (distdir </> "inplace-pkg-config") (toUTF8 content)
Ian Lynagh's avatar
Ian Lynagh committed
288
          _ -> error "Inconsistent lib components; can't happen?"
Ian Lynagh's avatar
Ian Lynagh committed
289 290

      let
Ian Lynagh's avatar
Ian Lynagh committed
291 292
          libBiModules lib = (libBuildInfo lib, libModules lib)
          exeBiModules exe = (buildInfo exe, ModuleName.main : exeModules exe)
Ian Lynagh's avatar
Ian Lynagh committed
293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317
          biModuless = (maybeToList $ fmap libBiModules $ library pd)
                    ++ (map exeBiModules $ executables pd)
          buildableBiModuless = filter isBuildable biModuless
              where isBuildable (bi', _) = buildable bi'
          (bi, modules) = case buildableBiModuless of
                          [] -> error "No buildable component found"
                          [biModules] -> biModules
                          _ -> error ("XXX ghc-cabal can't handle " ++
                                      "more than one buildinfo yet")
          -- XXX Another Just...
          Just ghcProg = lookupProgram ghcProgram (withPrograms lbi)

          dep_pkgs = PackageIndex.topologicalOrder (packageHacks (installedPkgs lbi))
          forDeps f = concatMap f dep_pkgs

          -- copied from Distribution.Simple.PreProcess.ppHsc2Hs
          packageHacks = case compilerFlavor (compiler lbi) of
            GHC -> hackRtsPackage
            _   -> id
          -- We don't link in the actual Haskell libraries of our
          -- dependencies, so the -u flags in the ldOptions of the rts
          -- package mean linking fails on OS X (it's ld is a tad
          -- stricter than gnu ld). Thus we remove the ldOptions for
          -- GHC's rts package:
          hackRtsPackage index =
318
            case PackageIndex.lookupPackageName index (PackageName "rts") of
319 320 321 322 323 324 325 326 327 328
              [(_,[rts])] ->
                 PackageIndex.insert rts{
                     Installed.ldOptions = [],
                     Installed.libraryDirs = filter (not . ("gcc-lib" `isSuffixOf`)) (Installed.libraryDirs rts)} index
                        -- GHC <= 6.12 had $topdir/gcc-lib in their
                        -- library-dirs for the rts package, which causes
                        -- problems when we try to use the in-tree mingw,
                        -- due to accidentally picking up the incompatible
                        -- libraries there.  So we filter out gcc-lib from
                        -- the RTS's library-dirs here.
Ian Lynagh's avatar
Ian Lynagh committed
329 330
              _ -> error "No (or multiple) ghc rts package is registered!!"

331
          dep_ids = map snd (externalPackageDeps lbi)
332

333 334 335
      wrappedIncludeDirs <- wrap $ forDeps Installed.includeDirs
      wrappedLibraryDirs <- wrap $ forDeps Installed.libraryDirs

Ian Lynagh's avatar
Ian Lynagh committed
336 337 338
      let variablePrefix = directory ++ '_':distdir
      let xs = [variablePrefix ++ "_VERSION = " ++ display (pkgVersion (package pd)),
                variablePrefix ++ "_MODULES = " ++ unwords (map display modules),
339
                variablePrefix ++ "_HIDDEN_MODULES = " ++ unwords (map display (otherModules bi)),
340
                variablePrefix ++ "_SYNOPSIS =" ++ synopsis pd,
Ian Lynagh's avatar
Ian Lynagh committed
341
                variablePrefix ++ "_HS_SRC_DIRS = " ++ unwords (hsSourceDirs bi),
342 343
                variablePrefix ++ "_DEPS = " ++ unwords (map display dep_ids),
                variablePrefix ++ "_DEP_NAMES = " ++ unwords (map (display . packageName) dep_ids),
Ian Lynagh's avatar
Ian Lynagh committed
344 345 346 347 348 349
                variablePrefix ++ "_INCLUDE_DIRS = " ++ unwords (includeDirs bi),
                variablePrefix ++ "_INCLUDES = " ++ unwords (includes bi),
                variablePrefix ++ "_INSTALL_INCLUDES = " ++ unwords (installIncludes bi),
                variablePrefix ++ "_EXTRA_LIBRARIES = " ++ unwords (extraLibs bi),
                variablePrefix ++ "_EXTRA_LIBDIRS = " ++ unwords (extraLibDirs bi),
                variablePrefix ++ "_C_SRCS  = " ++ unwords (cSources bi),
350
                variablePrefix ++ "_CMM_SRCS  := $(addprefix cbits/,$(notdir $(wildcard " ++ directory ++ "/cbits/*.cmm)))",
351
                variablePrefix ++ "_DATA_FILES = "    ++ unwords (dataFiles pd),
Ian Lynagh's avatar
Ian Lynagh committed
352 353
                -- XXX This includes things it shouldn't, like:
                -- -odir dist-bootstrapping/build
Ian Lynagh's avatar
Ian Lynagh committed
354 355
                variablePrefix ++ "_HC_OPTS = " ++ escape (unwords
                       (   programDefaultArgs ghcProg
Ian Lynagh's avatar
Ian Lynagh committed
356
                        ++ hcOptions GHC bi
357
                        ++ languageToFlags (compiler lbi) (defaultLanguage bi)
358
                        ++ extensionsToFlags (compiler lbi) (usedExtensions bi)
Ian Lynagh's avatar
Ian Lynagh committed
359
                        ++ programOverrideArgs ghcProg)),
Ian Lynagh's avatar
Ian Lynagh committed
360 361 362
                variablePrefix ++ "_CC_OPTS = "                        ++ unwords (ccOptions bi),
                variablePrefix ++ "_CPP_OPTS = "                       ++ unwords (cppOptions bi),
                variablePrefix ++ "_LD_OPTS = "                        ++ unwords (ldOptions bi),
363
                variablePrefix ++ "_DEP_INCLUDE_DIRS_SINGLE_QUOTED = " ++ unwords wrappedIncludeDirs,
Ian Lynagh's avatar
Ian Lynagh committed
364 365 366 367 368
                variablePrefix ++ "_DEP_CC_OPTS = "                    ++ unwords (forDeps Installed.ccOptions),
                variablePrefix ++ "_DEP_LIB_DIRS_SINGLE_QUOTED = "     ++ unwords wrappedLibraryDirs,
                variablePrefix ++ "_DEP_EXTRA_LIBS = "                 ++ unwords (forDeps Installed.extraLibraries),
                variablePrefix ++ "_DEP_LD_OPTS = "                    ++ unwords (forDeps Installed.ldOptions),
                variablePrefix ++ "_BUILD_GHCI_LIB = "                 ++ boolToYesNo (withGHCiLib lbi),
369 370 371
                "",
                -- Sometimes we need to modify the automatically-generated package-data.mk
                -- bindings in a special way for the GHC build system, so allow that here:
372
                "$(eval $(" ++ directory ++ "_PACKAGE_MAGIC))"
373
                ]
Ian Lynagh's avatar
Ian Lynagh committed
374
      writeFile (distdir ++ "/package-data.mk") $ unlines xs
375
      writeFile (distdir ++ "/haddock-prologue.txt") $
376 377
          if null (description pd) then synopsis pd
                                   else description pd
Ian Lynagh's avatar
Ian Lynagh committed
378 379
  where
     escape = foldr (\c xs -> if c == '#' then '\\':'#':xs else c:xs) []
380 381
     wrap = mapM wrap1
     wrap1 s
382 383
      | null s        = die ["Wrapping empty value"]
      | '\'' `elem` s = die ["Single quote in value to be wrapped:", s]
384 385 386
      -- We want to be able to assume things like <space><quote> is the
      -- start of a value, so check there are no spaces in confusing
      -- positions
387 388
      | head s == ' ' = die ["Leading space in value to be wrapped:", s]
      | last s == ' ' = die ["Trailing space in value to be wrapped:", s]
389
      | otherwise     = return ("\'" ++ s ++ "\'")
390 391
     boolToYesNo True = "YES"
     boolToYesNo False = "NO"