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

import Distribution.PackageDescription
import Distribution.Setup
import Distribution.Simple
import Distribution.Simple.Configure
import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.Utils
import Distribution.Verbosity
import System.Environment
10
import System.Info
11
12
13

main :: IO ()
main = do args <- getArgs
Ian Lynagh's avatar
Ian Lynagh committed
14
15
16
          case args of
              pref : ghcpkg : args' ->
                  let verbosity = case args' of
17
18
19
20
21
22
23
                              [] -> 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
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
                  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
                              }
42
43
44
          pdFile <- defaultPackageDesc verbosity
          pd <- readPackageDescription verbosity pdFile
          lbi <- getPersistBuildConfig
45
46
          let -- XXX These are almighty hacks, shadowing the base
              -- Setup.hs hacks
47
48
              extraExtraLibs = if (os == "mingw32") &&
                                  (pkgName (package pd) == "base")
49
50
51
                               then ["wsock32", "msvcrt", "kernel32",
                                     "user32", "shell32"]
                               else []
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
              mkLib filt = case library pd of
                           Just lib ->
                               let ems = filter filt $ exposedModules lib
                                   lib_bi = libBuildInfo lib
                                   lib_bi' = lib_bi {
                                                 extraLibs = extraExtraLibs
                                                         ++ extraLibs lib_bi
                                             }
                               in lib {
                                      exposedModules = ems,
                                      libBuildInfo = lib_bi'
                                   }
                           Nothing ->
                               error "Expected a library, but none found"
              -- There's no files for GHC.Prim, so we will fail if we
              -- try to copy them
              pd_copy = pd { library = Just (mkLib ("GHC.Prim" /=)) }
              pd_reg  = pd { library = Just (mkLib (const True)) }
Ian Lynagh's avatar
Ian Lynagh committed
70
71
72
73
74
75
76
              -- 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.
77
78
79
              lbi_reg = lbi { libsubdir = "$pkgid" }
          (copyHook simpleUserHooks) pd_copy lbi_copy userHooks copyFlags
          (regHook simpleUserHooks)  pd_reg  lbi_reg  userHooks registerFlags
Ian Lynagh's avatar
Ian Lynagh committed
80
          return ()
81