1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
|
import Control.Monad
import Data.Maybe
import Distribution.PackageDescription
import Distribution.PackageDescription.Parse
import Distribution.ReadE
import Distribution.Simple
import Distribution.Simple.Configure
import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.Program
import Distribution.Simple.Setup
import Distribution.Simple.Utils
import Distribution.Text
import Distribution.Verbosity
import System.Environment
main :: IO ()
main
= do args <- getArgs
case args of
"install" : ghcpkg : ghcpkgconf : destdir : topdir :
iprefix : ibindir : ilibdir : ilibexecdir : idynlibdir :
idatadir : idocdir : ihtmldir : ihaddockdir :
args' ->
case parseArgs args' of
(verbosity, distPref, enableShellWrappers, strip) ->
doInstall verbosity distPref enableShellWrappers strip
ghcpkg ghcpkgconf destdir topdir
iprefix ibindir ilibdir ilibexecdir
idynlibdir idatadir idocdir ihtmldir
ihaddockdir
_ ->
error ("Bad arguments: " ++ show args)
-- XXX We should really make Cabal do the hardwork here
parseArgs :: [String]
-> (Verbosity, -- verbosity
FilePath, -- dist prefix
Bool, -- enable shell wrappers?
Bool) -- strip exe?
parseArgs = f normal defaultDistPref False True
where f _ dp esw strip (('-':'v':val):args)
= f (readEOrFail flagToVerbosity val) dp esw strip args
f v _ esw strip ("--distpref":dp:args) = f v dp esw strip args
f v dp _ strip ("--enable-shell-wrappers":args) = f v dp True strip args
f v dp esw _ ("--disable-executable-stripping":args) = f v dp esw False args
f v dp esw strip [] = (v, dp, esw, strip)
f _ _ _ _ args = error ("Bad arguments: " ++ show args)
doInstall :: Verbosity -> FilePath -> Bool -> Bool
-> FilePath -> FilePath -> FilePath -> FilePath
-> FilePath -> FilePath -> FilePath -> FilePath -> FilePath
-> FilePath -> FilePath -> FilePath -> FilePath
-> IO ()
doInstall verbosity distPref enableShellWrappers strip
ghcpkg ghcpkgconf destdir topdir
iprefix ibindir ilibdir ilibexecdir idynlibdir idatadir
idocdir ihtmldir ihaddockdir =
do let userHooks = simpleUserHooks
copyto = if null destdir then NoCopyDest else CopyTo destdir
copyFlags = defaultCopyFlags {
copyDistPref = toFlag distPref,
copyUseWrapper = toFlag enableShellWrappers,
copyDest = toFlag copyto,
copyVerbosity = toFlag verbosity
}
registerFlags = defaultRegisterFlags {
regDistPref = toFlag distPref,
regPackageDB = toFlag GlobalPackageDB,
regVerbosity = toFlag verbosity,
regGenScript = toFlag $ False,
regInPlace = toFlag $ False
}
lbi <- getConfig verbosity distPref
let pd = localPkgDescr lbi
i = installDirTemplates lbi
-- This is an almighty hack. We need to register
-- ghc-prim:GHC.Prim, but it doesn't exist, get built, get
-- haddocked, get copied, etc.
pd_reg = if packageName pd == PackageName "ghc-prim"
then case library pd of
Just lib ->
let ems = fromJust (simpleParse "GHC.Prim")
: exposedModules lib
lib' = lib { exposedModules = ems }
in pd { library = Just lib' }
Nothing ->
error "Expected a library, but none found"
else pd
-- When coying, we need to actually give a concrete
-- directory to copy to rather than "$topdir"
toPathTemplate' = toPathTemplate . replaceTopdir topdir
i_copy = i { prefix = toPathTemplate' iprefix,
bindir = toPathTemplate' ibindir,
libdir = toPathTemplate' ilibdir,
dynlibdir = toPathTemplate' idynlibdir,
libexecdir = toPathTemplate' ilibexecdir,
datadir = toPathTemplate' idatadir,
docdir = toPathTemplate' idocdir,
htmldir = toPathTemplate' ihtmldir,
haddockdir = toPathTemplate' ihaddockdir
}
lbi_copy = lbi { installDirTemplates = i_copy,
stripExes = strip }
-- 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.
progs = withPrograms lbi
prog = ConfiguredProgram {
programId = programName ghcPkgProgram,
programVersion = Nothing,
programArgs = ["--force", "--global-conf", ghcpkgconf],
programLocation = UserSpecified ghcpkg
}
progs' = updateProgram prog progs
i_reg = i { prefix = toPathTemplate iprefix,
bindir = toPathTemplate ibindir,
libdir = toPathTemplate ilibdir,
dynlibdir = toPathTemplate idynlibdir,
libexecdir = toPathTemplate ilibexecdir,
datadir = toPathTemplate idatadir,
docdir = toPathTemplate idocdir,
htmldir = toPathTemplate ihtmldir,
haddockdir = toPathTemplate ihaddockdir
}
lbi_reg = lbi { installDirTemplates = i_reg,
withPrograms = progs' }
(copyHook simpleUserHooks) pd lbi_copy userHooks copyFlags
-- Cabal prints a scary "Package contains no library to register"
-- message if we call register but this is an executable package.
-- We therefore don't call it if we don't have a library for it.
when (isJust (library pd_reg)) $
(regHook simpleUserHooks) pd_reg lbi_reg userHooks registerFlags
return ()
replaceTopdir :: FilePath -> FilePath -> FilePath
replaceTopdir topdir ('$':'t':'o':'p':'d':'i':'r':p) = topdir ++ p
replaceTopdir topdir ('$':'h':'t':'t':'p':'t':'o':'p':'d':'i':'r':p)
= topdir ++ p
replaceTopdir _ p = p
-- Get the build info, merging the setup-config and buildinfo files.
getConfig :: Verbosity -> FilePath -> IO LocalBuildInfo
getConfig verbosity distPref = do
lbi <- getPersistBuildConfig distPref
maybe_infoFile <- defaultHookedPackageDesc
case maybe_infoFile of
Nothing -> return lbi
Just infoFile -> do
hbi <- readHookedBuildInfo verbosity infoFile
return lbi { localPkgDescr = updatePackageDescription hbi (localPkgDescr lbi)}
|
