2 import Distribution.PackageDescription
3 import Distribution.Simple
4 import Distribution.Simple.Configure
5 import Distribution.Simple.LocalBuildInfo
6 import Distribution.Simple.Program
7 import Distribution.Simple.Setup
8 import Distribution.Simple.Utils
9 import Distribution.Verbosity
10 import System.Environment
16 "register" : "--inplace" :args' ->
17 let verbosity = mkVerbosity args'
18 in doRegisterInplace verbosity
19 "install" : ghcpkg : ghcpkgconf : destdir : topdir :
20 iprefix : ibindir : ilibdir : ilibexecdir :
21 idatadir : idocdir : ihtmldir : iinterfacedir :
23 let verbosity = mkVerbosity args'
24 in doInstall verbosity ghcpkg ghcpkgconf destdir topdir
25 iprefix ibindir ilibdir ilibexecdir idatadir
26 idocdir ihtmldir iinterfacedir
28 error ("Bad arguments: " ++ show args)
30 mkVerbosity :: [String] -> Verbosity
31 mkVerbosity [] = normal
32 mkVerbosity ['-':'v':v] = let m = case v of
36 mkVerbosity args = error ("Bad arguments: " ++ show args)
38 doRegisterInplace :: Verbosity -> IO ()
39 doRegisterInplace verbosity =
40 do lbi <- getConfig verbosity
41 let registerFlags = emptyRegisterFlags { regInPlace = True }
42 pd = localPkgDescr lbi
43 pd_reg = if pkgName (package pd) == "base"
44 then case library pd of
46 let ems = "GHC.Prim" : exposedModules lib
47 lib' = lib { exposedModules = ems }
48 in pd { library = Just lib' }
50 error "Expected a library, but none found"
52 (regHook simpleUserHooks) pd_reg lbi simpleUserHooks registerFlags
55 doInstall :: Verbosity -> FilePath -> FilePath -> FilePath -> FilePath
56 -> FilePath -> FilePath -> FilePath -> FilePath -> FilePath
57 -> FilePath -> FilePath -> FilePath
59 doInstall verbosity ghcpkg ghcpkgconf destdir topdir
60 iprefix ibindir ilibdir ilibexecdir idatadir
61 idocdir ihtmldir iinterfacedir =
62 do let userHooks = simpleUserHooks
63 copyto = if null destdir then NoCopyDest else CopyTo destdir
64 copyFlags = (emptyCopyFlags copyto) {
65 copyVerbose = verbosity
67 registerFlags = emptyRegisterFlags {
68 regPackageDB = Just GlobalPackageDB,
69 regVerbose = verbosity,
73 lbi <- getConfig verbosity
74 let pd = localPkgDescr lbi
75 i = installDirTemplates lbi
76 -- This is an almighty hack. We need to register
77 -- base:GHC.Prim, but it doesn't exist, get built, get
78 -- haddocked, get copied, etc.
79 pd_reg = if pkgName (package pd) == "base"
80 then case library pd of
82 let ems = "GHC.Prim" : exposedModules lib
83 lib' = lib { exposedModules = ems }
84 in pd { library = Just lib' }
86 error "Expected a library, but none found"
88 -- When coying, we need to actually give a concrete
89 -- directory to copy to rather than "$topdir"
90 toPathTemplate' = toPathTemplate . replaceTopdir topdir
91 i_copy = i { prefixDirTemplate = toPathTemplate' iprefix,
92 binDirTemplate = toPathTemplate' ibindir,
93 libDirTemplate = toPathTemplate' ilibdir,
94 libexecDirTemplate = toPathTemplate' ilibexecdir,
95 dataDirTemplate = toPathTemplate' idatadir,
96 docDirTemplate = toPathTemplate' idocdir,
97 htmlDirTemplate = toPathTemplate' ihtmldir,
98 interfaceDirTemplate = toPathTemplate' iinterfacedir
100 lbi_copy = lbi { installDirTemplates = i_copy }
101 -- When we run GHC we give it a $topdir that includes the
102 -- $compiler/lib/ part of libsubdir, so we only want the
103 -- $pkgid part in the package.conf file. This is a bit of
105 progs = withPrograms lbi
106 prog = ConfiguredProgram {
107 programId = programName ghcPkgProgram,
108 programVersion = Nothing,
109 programArgs = ["--force", "--global-conf", ghcpkgconf],
110 programLocation = UserSpecified ghcpkg
112 progs' = updateProgram prog progs
113 i_reg = i { prefixDirTemplate = toPathTemplate iprefix,
114 binDirTemplate = toPathTemplate ibindir,
115 libDirTemplate = toPathTemplate ilibdir,
116 libexecDirTemplate = toPathTemplate ilibexecdir,
117 dataDirTemplate = toPathTemplate idatadir,
118 docDirTemplate = toPathTemplate idocdir,
119 htmlDirTemplate = toPathTemplate ihtmldir,
120 interfaceDirTemplate = toPathTemplate iinterfacedir
122 lbi_reg = lbi { installDirTemplates = i_reg,
123 withPrograms = progs' }
124 (copyHook simpleUserHooks) pd lbi_copy userHooks copyFlags
125 (regHook simpleUserHooks) pd_reg lbi_reg userHooks registerFlags
128 replaceTopdir :: FilePath -> FilePath -> FilePath
129 replaceTopdir topdir ('$':'t':'o':'p':'d':'i':'r':p) = topdir ++ p
130 replaceTopdir topdir ('$':'h':'t':'t':'p':'t':'o':'p':'d':'i':'r':p)
132 replaceTopdir _ p = p
134 -- Get the build info, merging the setup-config and buildinfo files.
135 getConfig :: Verbosity -> IO LocalBuildInfo
136 getConfig verbosity = do
137 lbi <- getPersistBuildConfig
138 maybe_infoFile <- defaultHookedPackageDesc
139 case maybe_infoFile of
140 Nothing -> return lbi
142 hbi <- readHookedBuildInfo verbosity infoFile
143 return lbi { localPkgDescr = updatePackageDescription hbi (localPkgDescr lbi)}