installPackage.hs 3.55 KB
Newer Older
1 2 3 4 5 6 7 8

import Distribution.PackageDescription
import Distribution.Setup
import Distribution.Simple
import Distribution.Simple.Configure
import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.Utils
import Distribution.Verbosity
Ian Lynagh's avatar
Ian Lynagh committed
9
import System.Cmd
10
import System.Environment
11
import System.Info
12 13 14

main :: IO ()
main = do args <- getArgs
Ian Lynagh's avatar
Ian Lynagh committed
15 16 17
          case args of
              pref : ghcpkg : args' ->
                  let verbosity = case args' of
18 19 20 21 22 23 24
                              [] -> normal
                              ['-':'v':v] ->
                                  let m = case v of
                                              "" -> Nothing
                                              _ -> Just v
                                  in flagToVerbosity m
                              _ -> error ("Bad arguments: " ++ show args)
Ian Lynagh's avatar
Ian Lynagh committed
25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42
                  in doit pref ghcpkg verbosity
              _ ->
                  error "Missing arguments"

doit :: FilePath -> FilePath -> Verbosity -> IO ()
doit pref ghcpkg verbosity =
       do let userHooks = simpleUserHooks
              copyFlags = CopyFlags {
                              copyDest = NoCopyDest,
                              copyVerbose = verbosity
                          }
              registerFlags = RegisterFlags {
                                  regUser = MaybeUserGlobal,
                                  regGenScript = False,
                                  regInPlace = False,
                                  regWithHcPkg = Just ghcpkg,
                                  regVerbose = verbosity
                              }
43 44 45
          pdFile <- defaultPackageDesc verbosity
          pd <- readPackageDescription verbosity pdFile
          lbi <- getPersistBuildConfig
46 47
          let -- XXX These are almighty hacks, shadowing the base
              -- Setup.hs hacks
48 49
              extraExtraLibs = if (os == "mingw32") &&
                                  (pkgName (package pd) == "base")
50 51 52
                               then ["wsock32", "msvcrt", "kernel32",
                                     "user32", "shell32"]
                               else []
53 54
              lib' = case library pd of
                         Just lib ->
55 56 57 58 59 60 61 62 63 64
                             let ems = filter (("GHC.Prim" /=))
                                     $ exposedModules lib
                                 lib_bi = libBuildInfo lib
                                 lib_bi' = lib_bi {
                                               extraLibs = extraExtraLibs
                                                       ++ extraLibs lib_bi
                                           }
                             in lib {
                                    exposedModules = ems,
                                    libBuildInfo = lib_bi'
65 66 67 68
                                 }
                         Nothing ->
                             error "Expected a library, but none found"
              pd' = pd { library = Just lib' }
Ian Lynagh's avatar
Ian Lynagh committed
69 70 71 72 73 74 75 76 77 78 79
              -- When coying, we need to actually give a concrete
              -- directory to copy to rather than "$topdir"
              lbi_copy = lbi { prefix = pref }
              -- When we run GHC we give it a $topdir that includes the
              -- $compiler/lib/ part of libsubdir, so we only want the
              -- $pkgid part in the package.conf file. This is a bit of
              -- a hack, really.
              lbi_register = lbi { libsubdir = "$pkgid" }
          (copyHook simpleUserHooks) pd' lbi_copy userHooks copyFlags
          (regHook simpleUserHooks) pd' lbi_register userHooks registerFlags
          return ()
80