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
|
import Distribution.PackageDescription
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.Verbosity
import System.Environment
main :: IO ()
main
= do args <- getArgs
case args of
"register" : "--inplace" :args' ->
let verbosity = mkVerbosity args'
in doRegisterInplace verbosity
"install" : ghcpkg : ghcpkgconf : destdir : topdir :
iprefix : ibindir : ilibdir : ilibexecdir : idynlibdir :
idatadir : idocdir : ihtmldir : ihaddockdir :
args' ->
let verbosity = mkVerbosity args'
in doInstall verbosity ghcpkg ghcpkgconf destdir topdir
iprefix ibindir ilibdir ilibexecdir idynlibdir idatadir
idocdir ihtmldir ihaddockdir
_ ->
error ("Bad arguments: " ++ show args)
mkVerbosity :: [String] -> Verbosity
mkVerbosity [] = normal
mkVerbosity ['-':'v':v] = let m = case v of
"" -> Nothing
_ -> Just v
in flagToVerbosity m
mkVerbosity args = error ("Bad arguments: " ++ show args)
doRegisterInplace :: Verbosity -> IO ()
doRegisterInplace verbosity =
do lbi <- getConfig verbosity
let registerFlags = defaultRegisterFlags { regInPlace = toFlag True }
pd = localPkgDescr lbi
pd_reg = if pkgName (package pd) == "ghc-prim"
then case library pd of
Just lib ->
let ems = "GHC.Prim" : exposedModules lib
lib' = lib { exposedModules = ems }
in pd { library = Just lib' }
Nothing ->
error "Expected a library, but none found"
else pd
(regHook simpleUserHooks) pd_reg lbi simpleUserHooks registerFlags
return ()
doInstall :: Verbosity -> FilePath -> FilePath -> FilePath -> FilePath
-> FilePath -> FilePath -> FilePath -> FilePath -> FilePath
-> FilePath -> FilePath -> FilePath -> FilePath
-> IO ()
doInstall verbosity 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 {
copyDest = toFlag copyto,
copyVerbose = toFlag verbosity
}
registerFlags = defaultRegisterFlags {
regPackageDB = toFlag GlobalPackageDB,
regVerbose = toFlag verbosity,
regGenScript = toFlag $ False,
regInPlace = toFlag $ False
}
lbi <- getConfig verbosity
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 pkgName (package pd) == "ghc-prim"
then case library pd of
Just lib ->
let ems = "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 }
-- 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
(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 -> IO LocalBuildInfo
getConfig verbosity = do
lbi <- getPersistBuildConfig
maybe_infoFile <- defaultHookedPackageDesc
case maybe_infoFile of
Nothing -> return lbi
Just infoFile -> do
hbi <- readHookedBuildInfo verbosity infoFile
return lbi { localPkgDescr = updatePackageDescription hbi (localPkgDescr lbi)}
|
