Add special support for haskeline
[ghc.git] / utils / ghc-cabal / ghc-cabal.hs
1
2 module Main (main) where
3
4 import Distribution.Compat.Exception
5 import qualified Distribution.ModuleName as ModuleName
6 import Distribution.PackageDescription
7 import Distribution.PackageDescription.Configuration
8 import Distribution.PackageDescription.Parse
9 import Distribution.Simple
10 import Distribution.Simple.Configure
11 import Distribution.Simple.LocalBuildInfo
12 import Distribution.Simple.Program
13 import Distribution.Simple.Utils (defaultPackageDesc, withTempFile)
14 import Distribution.Simple.Build (writeAutogenFiles)
15 import Distribution.Simple.Register (writeInstalledConfig)
16 import Distribution.Simple.PackageIndex
17 import Distribution.Text
18 import Distribution.Verbosity
19 import qualified Distribution.InstalledPackageInfo as Installed
20 ( InstalledPackageInfo_(..) )
21 import qualified Distribution.Simple.PackageIndex as PackageIndex
22 ( topologicalOrder, lookupPackageName, insert )
23
24 import Control.Exception
25 import Control.Monad
26 import Data.Maybe
27 import System.IO
28 import System.Directory
29 import System.Environment
30 import System.Exit
31 import System.FilePath
32
33 main :: IO ()
34 main = do args <- getArgs
35 case args of
36 "haddock" : distDir : dir : args' ->
37 runHaddock distDir dir args'
38 "install" : ghcpkg : ghcpkgconfig : directory : distDir
39 : myDestDir : myPrefix : myLibdir : myDocdir : args' ->
40 doInstall ghcpkg ghcpkgconfig directory distDir
41 myDestDir myPrefix myLibdir myDocdir args'
42 "configure" : args' -> case break (== "--") args' of
43 (config_args, "--" : distdir : directories) ->
44 mapM_ (generate config_args distdir) directories
45 _ -> die syntax_error
46 _ -> die syntax_error
47
48 syntax_error :: [String]
49 syntax_error =
50 ["syntax: ghc-cabal configure <configure-args> -- <distdir> <directory>...",
51 " ghc-cabal install <ghc-pkg> <directory> <distdir> <destdir> <prefix> <args>...",
52 " ghc-cabal haddock <distdir> <directory> <args>..."]
53
54 die :: [String] -> IO ()
55 die errs = do mapM_ (hPutStrLn stderr) errs
56 exitWith (ExitFailure 1)
57
58 -- XXX Should use bracket
59 withCurrentDirectory :: FilePath -> IO a -> IO a
60 withCurrentDirectory directory io
61 = do curDirectory <- getCurrentDirectory
62 setCurrentDirectory directory
63 r <- io
64 setCurrentDirectory curDirectory
65 return r
66
67 -- We need to use the autoconfUserHooks, as the packages that use
68 -- configure can create a .buildinfo file, and we need any info that
69 -- ends up in it.
70 userHooks :: UserHooks
71 userHooks = autoconfUserHooks
72
73 runHaddock :: FilePath -> FilePath -> [String] -> IO ()
74 runHaddock distdir directory args
75 = withCurrentDirectory directory
76 $ defaultMainWithHooksArgs hooks ("haddock" : "--builddir" : distdir : args)
77 where
78 hooks = userHooks {
79 haddockHook = modHook (haddockHook userHooks)
80 }
81 modHook f pd lbi us flags
82 | packageName pd == PackageName "ghc-prim"
83 = let pd' = case library pd of
84 Just lib ->
85 let ghcPrim = fromJust (simpleParse "GHC.Prim")
86 ems = filter (ghcPrim /=)
87 (exposedModules lib)
88 lib' = lib { exposedModules = ems }
89 in pd { library = Just lib' }
90 Nothing ->
91 error "Expected a library, but none found"
92 pc = withPrograms lbi
93 pc' = userSpecifyArgs "haddock"
94 ["dist-install/build/autogen/GHC/Prim.hs"] pc
95 lbi' = lbi { withPrograms = pc' }
96 in f pd' lbi' us flags
97 | otherwise
98 = f pd lbi us flags
99
100 doInstall :: FilePath -> FilePath -> FilePath -> FilePath -> FilePath
101 -> FilePath -> FilePath -> FilePath -> [String] -> IO ()
102 doInstall ghcpkg ghcpkgconf directory distDir myDestDir myPrefix myLibdir myDocdir args
103 = withCurrentDirectory directory $ do
104 defaultMainWithHooksArgs hooks (["copy", "--builddir", distDir]
105 ++ (if null myDestDir then []
106 else ["--destdir", myDestDir])
107 ++ args)
108 defaultMainWithHooksArgs hooks ("register" : "--builddir" : distDir : args)
109 where
110 hooks = userHooks {
111 copyHook = modHook (copyHook userHooks),
112 regHook = modHook (regHook userHooks)
113 }
114
115 modHook f pd lbi us flags
116 = let
117 pd'
118 | packageName pd == PackageName "ghc-prim" =
119 case library pd of
120 Just lib ->
121 let ghcPrim = fromJust (simpleParse "GHC.Prim")
122 ems = filter (ghcPrim /=) (exposedModules lib)
123 lib' = lib { exposedModules = ems }
124 in pd { library = Just lib' }
125 Nothing ->
126 error "Expected a library, but none found"
127 | otherwise = pd
128 idts = installDirTemplates lbi
129 idts' = idts { prefix = toPathTemplate myPrefix,
130 libdir = toPathTemplate myLibdir,
131 libsubdir = toPathTemplate "$pkgid",
132 docdir = toPathTemplate (myDocdir </> "$pkgid"),
133 htmldir = toPathTemplate "$docdir" }
134 progs = withPrograms lbi
135 prog = ConfiguredProgram {
136 programId = programName ghcPkgProgram,
137 programVersion = Nothing,
138 programArgs = ["--global-conf", ghcpkgconf]
139 ++ if not (null myDestDir)
140 then ["--force"]
141 else [],
142 programLocation = UserSpecified ghcpkg
143 }
144 progs' = updateProgram prog progs
145 lbi' = lbi {
146 installDirTemplates = idts',
147 withPrograms = progs'
148 }
149 in f pd' lbi' us flags
150
151 generate :: [String] -> FilePath -> FilePath -> IO ()
152 generate config_args distdir directory
153 = withCurrentDirectory directory
154 $ do let verbosity = normal
155 gpdFile <- defaultPackageDesc verbosity
156 gpd <- readPackageDescription verbosity gpdFile
157
158 -- XXX We shouldn't just configure with the default flags
159 -- XXX And this, and thus the "getPersistBuildConfig distdir" below,
160 -- aren't going to work when the deps aren't built yet
161 withArgs (["configure", "--distdir", distdir] ++ config_args)
162 (case buildType (flattenPackageDescription gpd) of
163 Just Configure -> defaultMainWithHooks autoconfUserHooks
164 _other -> defaultMain)
165 -- not quite right, but good enough for us
166
167 lbi <- getPersistBuildConfig distdir
168 let pd0 = localPkgDescr lbi
169
170 -- Sigh, haskeline proper uses stuff in Setup.hs to handle whether
171 -- or not -liconv is used. We don't use Setup.hs, so we replicate
172 -- what it does here. We should do this better somehow.
173 when (display (pkgName (package pd0)) == "haskeline") $
174 case library pd0 of
175 Nothing -> fail "Can't happen: No haskeline library"
176 Just lib -> do
177 d <- getCurrentDirectory
178 print d
179 maybeSetLibiconv verbosity (libBuildInfo lib) lbi
180
181 hooked_bi <-
182 if (buildType pd0 == Just Configure)
183 then do
184 maybe_infoFile <- defaultHookedPackageDesc
185 case maybe_infoFile of
186 Nothing -> return emptyHookedBuildInfo
187 Just infoFile -> readHookedBuildInfo verbosity infoFile
188 else
189 return emptyHookedBuildInfo
190
191 let pd = updatePackageDescription hooked_bi pd0
192
193 -- generate Paths_<pkg>.hs and cabal-macros.h
194 writeAutogenFiles verbosity pd lbi
195
196 -- generate inplace-pkg-config
197 when (isJust $ library pd) $
198 writeInstalledConfig distdir pd lbi True Nothing
199
200 let
201 libBiModules lib = (libBuildInfo lib, libModules pd)
202 exeBiModules exe = (buildInfo exe, ModuleName.main : exeModules pd)
203 biModuless = (maybeToList $ fmap libBiModules $ library pd)
204 ++ (map exeBiModules $ executables pd)
205 buildableBiModuless = filter isBuildable biModuless
206 where isBuildable (bi', _) = buildable bi'
207 (bi, modules) = case buildableBiModuless of
208 [] -> error "No buildable component found"
209 [biModules] -> biModules
210 _ -> error ("XXX ghc-cabal can't handle " ++
211 "more than one buildinfo yet")
212 -- XXX Another Just...
213 Just ghcProg = lookupProgram ghcProgram (withPrograms lbi)
214
215 dep_pkgs = PackageIndex.topologicalOrder (packageHacks (installedPkgs lbi))
216 forDeps f = concatMap f dep_pkgs
217
218 -- copied from Distribution.Simple.PreProcess.ppHsc2Hs
219 packageHacks = case compilerFlavor (compiler lbi) of
220 GHC -> hackRtsPackage
221 _ -> id
222 -- We don't link in the actual Haskell libraries of our
223 -- dependencies, so the -u flags in the ldOptions of the rts
224 -- package mean linking fails on OS X (it's ld is a tad
225 -- stricter than gnu ld). Thus we remove the ldOptions for
226 -- GHC's rts package:
227 hackRtsPackage index =
228 case PackageIndex.lookupPackageName index (PackageName "rts") of
229 [rts] -> PackageIndex.insert rts { Installed.ldOptions = [] } index
230 _ -> error "No (or multiple) ghc rts package is registered!!"
231
232 let variablePrefix = directory ++ '_':distdir
233 let xs = [variablePrefix ++ "_VERSION = " ++ display (pkgVersion (package pd)),
234 variablePrefix ++ "_MODULES = " ++ unwords (map display modules),
235 variablePrefix ++ "_HS_SRC_DIRS = " ++ unwords (hsSourceDirs bi),
236 variablePrefix ++ "_DEPS = " ++ unwords (map display (packageDeps lbi)),
237 variablePrefix ++ "_DEP_NAMES = " ++ unwords (map (display . packageName) (packageDeps lbi)),
238 variablePrefix ++ "_INCLUDE_DIRS = " ++ unwords (includeDirs bi),
239 variablePrefix ++ "_INCLUDES = " ++ unwords (includes bi),
240 variablePrefix ++ "_INSTALL_INCLUDES = " ++ unwords (installIncludes bi),
241 variablePrefix ++ "_EXTRA_LIBRARIES = " ++ unwords (extraLibs bi),
242 variablePrefix ++ "_EXTRA_LIBDIRS = " ++ unwords (extraLibDirs bi),
243 variablePrefix ++ "_C_SRCS = " ++ unwords (cSources bi),
244 -- XXX This includes things it shouldn't, like:
245 -- -odir dist-bootstrapping/build
246 variablePrefix ++ "_HC_OPTS = " ++ escape (unwords
247 (programArgs ghcProg
248 ++ hcOptions GHC bi
249 ++ extensionsToFlags (compiler lbi) (extensions bi))),
250 variablePrefix ++ "_CC_OPTS = " ++ unwords (ccOptions bi),
251 variablePrefix ++ "_CPP_OPTS = " ++ unwords (cppOptions bi),
252 variablePrefix ++ "_LD_OPTS = " ++ unwords (ldOptions bi),
253 variablePrefix ++ "_DEP_INCLUDE_DIRS = " ++ unwords (forDeps Installed.includeDirs),
254 variablePrefix ++ "_DEP_CC_OPTS = " ++ unwords (forDeps Installed.ccOptions),
255 variablePrefix ++ "_DEP_LIB_DIRS = " ++ unwords (forDeps Installed.libraryDirs),
256 variablePrefix ++ "_DEP_EXTRA_LIBS = " ++ unwords (forDeps Installed.extraLibraries),
257 variablePrefix ++ "_DEP_LD_OPTS = " ++ unwords (forDeps Installed.ldOptions)]
258 writeFile (distdir ++ "/package-data.mk") $ unlines xs
259 where
260 escape = foldr (\c xs -> if c == '#' then '\\':'#':xs else c:xs) []
261
262 ----------------------------------------------------------------------
263 -- haskeline-specific hacks
264
265 -- Sigh, haskeline proper uses stuff in Setup.hs to handle whether
266 -- or not -liconv is used. We don't use Setup.hs, so we replicate
267 -- what it does here. We should do this better somehow.
268
269 -- Test whether compiling a c program that links against libiconv needs -liconv.
270 maybeSetLibiconv :: Verbosity -> BuildInfo -> LocalBuildInfo -> IO ()
271 maybeSetLibiconv verb bi lbi = do
272 let biWithIconv = addIconv bi
273 worksWithout <- tryCompile iconv_prog bi lbi verb
274 if worksWithout
275 then writeBuildInfo ""
276 else do
277 worksWith <- tryCompile iconv_prog biWithIconv lbi verb
278 if worksWith
279 then do
280 writeBuildInfo "iconv"
281 else fail "Unable to link against the iconv library."
282 where
283 -- Cabal (at least 1.6.0.1) won't parse an empty buildinfo file.
284 writeBuildInfo libs = writeFile "haskeline.buildinfo"
285 $ unlines ["extra-libraries: " ++ libs]
286
287 tryCompile :: String -> BuildInfo -> LocalBuildInfo -> Verbosity -> IO Bool
288 tryCompile program bi lbi verb = flip catchIO processException $ flip catchExit processExit $ do
289 tempDir <- getTemporaryDirectory
290 withTempFile tempDir ".c" $ \fname h -> do
291 hPutStr h program
292 hClose h
293 -- TODO take verbosity from the args.
294 rawSystemProgramStdoutConf verb gccProgram (withPrograms lbi) (fname : args)
295 return True
296 where
297 processException :: IOException -> IO Bool
298 processException _ = return False
299 processExit = return . (==ExitSuccess)
300 -- Mimicing Distribution.Simple.Configure
301 deps = topologicalOrder (installedPkgs lbi)
302 args = concat
303 [ ccOptions bi
304 , cppOptions bi
305 , ldOptions bi
306 -- --extra-include-dirs and --extra-lib-dirs are included
307 -- in the below fields.
308 -- Also sometimes a dependency like rts points to a nonstandard
309 -- include/lib directory where iconv can be found.
310 , map ("-I" ++) (includeDirs bi ++ concatMap Installed.includeDirs deps)
311 , map ("-L" ++) (extraLibDirs bi ++ concatMap Installed.libraryDirs deps)
312 , map ("-l" ++) (extraLibs bi)
313 ]
314
315 addIconv :: BuildInfo -> BuildInfo
316 addIconv bi = bi {extraLibs = "iconv" : extraLibs bi}
317
318 iconv_prog :: String
319 iconv_prog = unlines $
320 [ "#include <iconv.h>"
321 , "int main(void) {"
322 , " iconv_t t = iconv_open(\"UTF-8\", \"UTF-8\");"
323 , " return 0;"
324 , "}"
325 ]
326