libraries/installPackage.hs

   1
   2 import Distribution.PackageDescription
   3 import Distribution.PackageDescription.Parse
   4 import Distribution.ReadE
   5 import Distribution.Simple
   6 import Distribution.Simple.Configure
   7 import Distribution.Simple.LocalBuildInfo
   8 import Distribution.Simple.Program
   9 import Distribution.Simple.Setup
  10 import Distribution.Simple.Utils
  11 import Distribution.Verbosity
  12 import System.Environment
  13
  14 -- XXX This will need to be changed
  15 distPref :: FilePath
  16 distPref = defaultDistPref
  17
  18 main :: IO ()
  19 main
  20   = do args <- getArgs
  21        case args of
  22            "install" : ghcpkg : ghcpkgconf : destdir : topdir :
  23                     iprefix : ibindir : ilibdir : ilibexecdir : idynlibdir :
  24                     idatadir : idocdir : ihtmldir : ihaddockdir :
  25                     args' ->
  26                let verbosity = mkVerbosity args'
  27                in doInstall verbosity ghcpkg ghcpkgconf destdir topdir
  28                             iprefix ibindir ilibdir ilibexecdir idynlibdir idatadir
  29                             idocdir ihtmldir ihaddockdir
  30            _ ->
  31                error ("Bad arguments: " ++ show args)
  32
  33 mkVerbosity :: [String] -> Verbosity
  34 mkVerbosity [] = normal
  35 mkVerbosity ['-':'v':v] = readEOrFail flagToVerbosity v
  36 mkVerbosity args = error ("Bad arguments: " ++ show args)
  37
  38 doInstall :: Verbosity -> FilePath -> FilePath -> FilePath -> FilePath
  39           -> FilePath -> FilePath -> FilePath -> FilePath -> FilePath
  40           -> FilePath -> FilePath -> FilePath -> FilePath
  41           -> IO ()
  42 doInstall verbosity ghcpkg ghcpkgconf destdir topdir
  43      iprefix ibindir ilibdir ilibexecdir idynlibdir idatadir
  44      idocdir ihtmldir ihaddockdir =
  45        do let userHooks = simpleUserHooks
  46               copyto = if null destdir then NoCopyDest else CopyTo destdir
  47               copyFlags = defaultCopyFlags {
  48                               copyDest = toFlag copyto,
  49                               copyVerbosity = toFlag verbosity
  50                           }
  51               registerFlags = defaultRegisterFlags {
  52                                   regPackageDB = toFlag GlobalPackageDB,
  53                                   regVerbosity = toFlag verbosity,
  54                                   regGenScript = toFlag $ False,
  55                                   regInPlace = toFlag $ False
  56                               }
  57           lbi <- getConfig verbosity
  58           let pd = localPkgDescr lbi
  59               i = installDirTemplates lbi
  60               -- This is an almighty hack. We need to register
  61               -- ghc-prim:GHC.Prim, but it doesn't exist, get built, get
  62               -- haddocked, get copied, etc.
  63               pd_reg = if pkgName (package pd) == "ghc-prim"
  64                        then case library pd of
  65                             Just lib ->
  66                                 let ems = "GHC.Prim" : exposedModules lib
  67                                     lib' = lib { exposedModules = ems }
  68                                 in pd { library = Just lib' }
  69                             Nothing ->
  70                                 error "Expected a library, but none found"
  71                        else pd
  72               -- When coying, we need to actually give a concrete
  73               -- directory to copy to rather than "$topdir"
  74               toPathTemplate' = toPathTemplate . replaceTopdir topdir
  75               i_copy = i { prefix       = toPathTemplate' iprefix,
  76                            bindir       = toPathTemplate' ibindir,
  77                            libdir       = toPathTemplate' ilibdir,
  78                            dynlibdir    = toPathTemplate' idynlibdir,
  79                            libexecdir   = toPathTemplate' ilibexecdir,
  80                            datadir      = toPathTemplate' idatadir,
  81                            docdir       = toPathTemplate' idocdir,
  82                            htmldir      = toPathTemplate' ihtmldir,
  83                            haddockdir   = toPathTemplate' ihaddockdir
  84                          }
  85               lbi_copy = lbi { installDirTemplates = i_copy }
  86               -- When we run GHC we give it a $topdir that includes the
  87               -- $compiler/lib/ part of libsubdir, so we only want the
  88               -- $pkgid part in the package.conf file. This is a bit of
  89               -- a hack, really.
  90               progs = withPrograms lbi
  91               prog = ConfiguredProgram {
  92                          programId = programName ghcPkgProgram,
  93                          programVersion = Nothing,
  94                          programArgs = ["--force", "--global-conf", ghcpkgconf],
  95                          programLocation = UserSpecified ghcpkg
  96                      }
  97               progs' = updateProgram prog progs
  98               i_reg = i { prefix       = toPathTemplate iprefix,
  99                           bindir       = toPathTemplate ibindir,
 100                           libdir       = toPathTemplate ilibdir,
 101                           dynlibdir    = toPathTemplate idynlibdir,
 102                           libexecdir   = toPathTemplate ilibexecdir,
 103                           datadir      = toPathTemplate idatadir,
 104                           docdir       = toPathTemplate idocdir,
 105                           htmldir      = toPathTemplate ihtmldir,
 106                           haddockdir   = toPathTemplate ihaddockdir
 107                         }
 108               lbi_reg = lbi { installDirTemplates = i_reg,
 109                               withPrograms = progs' }
 110           (copyHook simpleUserHooks) pd     lbi_copy userHooks copyFlags
 111           (regHook simpleUserHooks)  pd_reg lbi_reg  userHooks registerFlags
 112           return ()
 113
 114 replaceTopdir :: FilePath -> FilePath -> FilePath
 115 replaceTopdir topdir ('$':'t':'o':'p':'d':'i':'r':p) = topdir ++ p
 116 replaceTopdir topdir ('$':'h':'t':'t':'p':'t':'o':'p':'d':'i':'r':p)
 117     = topdir ++ p
 118 replaceTopdir _ p = p
 119
 120 -- Get the build info, merging the setup-config and buildinfo files.
 121 getConfig :: Verbosity -> IO LocalBuildInfo
 122 getConfig verbosity = do
 123     lbi <- getPersistBuildConfig distPref
 124     maybe_infoFile <- defaultHookedPackageDesc
 125     case maybe_infoFile of
 126         Nothing -> return lbi
 127         Just infoFile -> do
 128             hbi <- readHookedBuildInfo verbosity infoFile
 129             return lbi { localPkgDescr = updatePackageDescription hbi (localPkgDescr lbi)}
 130
 131