Simplify type of ms_srcimps and ms_textual_imps.
[ghc.git] / compiler / main / DriverMkDepend.hs
1 {-# LANGUAGE CPP #-}
2
3 -----------------------------------------------------------------------------
4 --
5 -- Makefile Dependency Generation
6 --
7 -- (c) The University of Glasgow 2005
8 --
9 -----------------------------------------------------------------------------
10
11 module DriverMkDepend (
12 doMkDependHS
13 ) where
14
15 #include "HsVersions.h"
16
17 import qualified GHC
18 import GhcMonad
19 import DynFlags
20 import Util
21 import HscTypes
22 import SysTools ( newTempName )
23 import qualified SysTools
24 import Module
25 import Digraph ( SCC(..) )
26 import Finder
27 import Outputable
28 import Panic
29 import SrcLoc
30 import Data.List
31 import FastString
32
33 import Exception
34 import ErrUtils
35
36 import System.Directory
37 import System.FilePath
38 import System.IO
39 import System.IO.Error ( isEOFError )
40 import Control.Monad ( when )
41 import Data.Maybe ( isJust )
42
43 -----------------------------------------------------------------
44 --
45 -- The main function
46 --
47 -----------------------------------------------------------------
48
49 doMkDependHS :: GhcMonad m => [FilePath] -> m ()
50 doMkDependHS srcs = do
51 -- Initialisation
52 dflags0 <- GHC.getSessionDynFlags
53
54 -- We kludge things a bit for dependency generation. Rather than
55 -- generating dependencies for each way separately, we generate
56 -- them once and then duplicate them for each way's osuf/hisuf.
57 -- We therefore do the initial dependency generation with an empty
58 -- way and .o/.hi extensions, regardless of any flags that might
59 -- be specified.
60 let dflags = dflags0 {
61 ways = [],
62 buildTag = mkBuildTag [],
63 hiSuf = "hi",
64 objectSuf = "o"
65 }
66 _ <- GHC.setSessionDynFlags dflags
67
68 when (null (depSuffixes dflags)) $ liftIO $
69 throwGhcExceptionIO (ProgramError "You must specify at least one -dep-suffix")
70
71 files <- liftIO $ beginMkDependHS dflags
72
73 -- Do the downsweep to find all the modules
74 targets <- mapM (\s -> GHC.guessTarget s Nothing) srcs
75 GHC.setTargets targets
76 let excl_mods = depExcludeMods dflags
77 mod_summaries <- GHC.depanal excl_mods True {- Allow dup roots -}
78
79 -- Sort into dependency order
80 -- There should be no cycles
81 let sorted = GHC.topSortModuleGraph False mod_summaries Nothing
82
83 -- Print out the dependencies if wanted
84 liftIO $ debugTraceMsg dflags 2 (text "Module dependencies" $$ ppr sorted)
85
86 -- Prcess them one by one, dumping results into makefile
87 -- and complaining about cycles
88 hsc_env <- getSession
89 root <- liftIO getCurrentDirectory
90 mapM_ (liftIO . processDeps dflags hsc_env excl_mods root (mkd_tmp_hdl files)) sorted
91
92 -- If -ddump-mod-cycles, show cycles in the module graph
93 liftIO $ dumpModCycles dflags mod_summaries
94
95 -- Tidy up
96 liftIO $ endMkDependHS dflags files
97
98 -- Unconditional exiting is a bad idea. If an error occurs we'll get an
99 --exception; if that is not caught it's fine, but at least we have a
100 --chance to find out exactly what went wrong. Uncomment the following
101 --line if you disagree.
102
103 --`GHC.ghcCatch` \_ -> io $ exitWith (ExitFailure 1)
104
105 -----------------------------------------------------------------
106 --
107 -- beginMkDependHs
108 -- Create a temporary file,
109 -- find the Makefile,
110 -- slurp through it, etc
111 --
112 -----------------------------------------------------------------
113
114 data MkDepFiles
115 = MkDep { mkd_make_file :: FilePath, -- Name of the makefile
116 mkd_make_hdl :: Maybe Handle, -- Handle for the open makefile
117 mkd_tmp_file :: FilePath, -- Name of the temporary file
118 mkd_tmp_hdl :: Handle } -- Handle of the open temporary file
119
120 beginMkDependHS :: DynFlags -> IO MkDepFiles
121 beginMkDependHS dflags = do
122 -- open a new temp file in which to stuff the dependency info
123 -- as we go along.
124 tmp_file <- newTempName dflags "dep"
125 tmp_hdl <- openFile tmp_file WriteMode
126
127 -- open the makefile
128 let makefile = depMakefile dflags
129 exists <- doesFileExist makefile
130 mb_make_hdl <-
131 if not exists
132 then return Nothing
133 else do
134 makefile_hdl <- openFile makefile ReadMode
135
136 -- slurp through until we get the magic start string,
137 -- copying the contents into dep_makefile
138 let slurp = do
139 l <- hGetLine makefile_hdl
140 if (l == depStartMarker)
141 then return ()
142 else do hPutStrLn tmp_hdl l; slurp
143
144 -- slurp through until we get the magic end marker,
145 -- throwing away the contents
146 let chuck = do
147 l <- hGetLine makefile_hdl
148 if (l == depEndMarker)
149 then return ()
150 else chuck
151
152 catchIO slurp
153 (\e -> if isEOFError e then return () else ioError e)
154 catchIO chuck
155 (\e -> if isEOFError e then return () else ioError e)
156
157 return (Just makefile_hdl)
158
159
160 -- write the magic marker into the tmp file
161 hPutStrLn tmp_hdl depStartMarker
162
163 return (MkDep { mkd_make_file = makefile, mkd_make_hdl = mb_make_hdl,
164 mkd_tmp_file = tmp_file, mkd_tmp_hdl = tmp_hdl})
165
166
167 -----------------------------------------------------------------
168 --
169 -- processDeps
170 --
171 -----------------------------------------------------------------
172
173 processDeps :: DynFlags
174 -> HscEnv
175 -> [ModuleName]
176 -> FilePath
177 -> Handle -- Write dependencies to here
178 -> SCC ModSummary
179 -> IO ()
180 -- Write suitable dependencies to handle
181 -- Always:
182 -- this.o : this.hs
183 --
184 -- If the dependency is on something other than a .hi file:
185 -- this.o this.p_o ... : dep
186 -- otherwise
187 -- this.o ... : dep.hi
188 -- this.p_o ... : dep.p_hi
189 -- ...
190 -- (where .o is $osuf, and the other suffixes come from
191 -- the cmdline -s options).
192 --
193 -- For {-# SOURCE #-} imports the "hi" will be "hi-boot".
194
195 processDeps dflags _ _ _ _ (CyclicSCC nodes)
196 = -- There shouldn't be any cycles; report them
197 throwGhcExceptionIO (ProgramError (showSDoc dflags $ GHC.cyclicModuleErr nodes))
198
199 processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC node)
200 | Just src_file <- msHsFilePath node
201 = do { let extra_suffixes = depSuffixes dflags
202 include_pkg_deps = depIncludePkgDeps dflags
203 obj_file = msObjFilePath node
204 obj_files = insertSuffixes obj_file extra_suffixes
205
206 do_imp loc is_boot pkg_qual imp_mod
207 = do { mb_hi <- findDependency hsc_env loc pkg_qual imp_mod
208 is_boot include_pkg_deps
209 ; case mb_hi of {
210 Nothing -> return () ;
211 Just hi_file -> do
212 { let hi_files = insertSuffixes hi_file extra_suffixes
213 write_dep (obj,hi) = writeDependency root hdl [obj] hi
214
215 -- Add one dependency for each suffix;
216 -- e.g. A.o : B.hi
217 -- A.x_o : B.x_hi
218 ; mapM_ write_dep (obj_files `zip` hi_files) }}}
219
220
221 -- Emit std dependency of the object(s) on the source file
222 -- Something like A.o : A.hs
223 ; writeDependency root hdl obj_files src_file
224
225 -- Emit a dependency for each import
226
227 ; let do_imps is_boot idecls = sequence_
228 [ do_imp loc is_boot mb_pkg mod
229 | (mb_pkg, L loc mod) <- idecls,
230 mod `notElem` excl_mods ]
231
232 ; do_imps True (ms_srcimps node)
233 ; do_imps False (ms_imps node)
234 }
235
236 | otherwise
237 = ASSERT( ms_hsc_src node == HsBootMerge )
238 panic "HsBootMerge not supported in DriverMkDepend yet"
239
240
241 findDependency :: HscEnv
242 -> SrcSpan
243 -> Maybe FastString -- package qualifier, if any
244 -> ModuleName -- Imported module
245 -> IsBootInterface -- Source import
246 -> Bool -- Record dependency on package modules
247 -> IO (Maybe FilePath) -- Interface file file
248 findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps
249 = do { -- Find the module; this will be fast because
250 -- we've done it once during downsweep
251 r <- findImportedModule hsc_env imp pkg
252 ; case r of
253 Found loc _
254 -- Home package: just depend on the .hi or hi-boot file
255 | isJust (ml_hs_file loc) || include_pkg_deps
256 -> return (Just (addBootSuffix_maybe is_boot (ml_hi_file loc)))
257
258 -- Not in this package: we don't need a dependency
259 | otherwise
260 -> return Nothing
261
262 fail ->
263 let dflags = hsc_dflags hsc_env
264 in throwOneError $ mkPlainErrMsg dflags srcloc $
265 cannotFindModule dflags imp fail
266 }
267
268 -----------------------------
269 writeDependency :: FilePath -> Handle -> [FilePath] -> FilePath -> IO ()
270 -- (writeDependency r h [t1,t2] dep) writes to handle h the dependency
271 -- t1 t2 : dep
272 writeDependency root hdl targets dep
273 = do let -- We need to avoid making deps on
274 -- c:/foo/...
275 -- on cygwin as make gets confused by the :
276 -- Making relative deps avoids some instances of this.
277 dep' = makeRelative root dep
278 forOutput = escapeSpaces . reslash Forwards . normalise
279 output = unwords (map forOutput targets) ++ " : " ++ forOutput dep'
280 hPutStrLn hdl output
281
282 -----------------------------
283 insertSuffixes
284 :: FilePath -- Original filename; e.g. "foo.o"
285 -> [String] -- Suffix prefixes e.g. ["x_", "y_"]
286 -> [FilePath] -- Zapped filenames e.g. ["foo.x_o", "foo.y_o"]
287 -- Note that that the extra bit gets inserted *before* the old suffix
288 -- We assume the old suffix contains no dots, so we know where to
289 -- split it
290 insertSuffixes file_name extras
291 = [ basename <.> (extra ++ suffix) | extra <- extras ]
292 where
293 (basename, suffix) = case splitExtension file_name of
294 -- Drop the "." from the extension
295 (b, s) -> (b, drop 1 s)
296
297
298 -----------------------------------------------------------------
299 --
300 -- endMkDependHs
301 -- Complete the makefile, close the tmp file etc
302 --
303 -----------------------------------------------------------------
304
305 endMkDependHS :: DynFlags -> MkDepFiles -> IO ()
306
307 endMkDependHS dflags
308 (MkDep { mkd_make_file = makefile, mkd_make_hdl = makefile_hdl,
309 mkd_tmp_file = tmp_file, mkd_tmp_hdl = tmp_hdl })
310 = do
311 -- write the magic marker into the tmp file
312 hPutStrLn tmp_hdl depEndMarker
313
314 case makefile_hdl of
315 Nothing -> return ()
316 Just hdl -> do
317
318 -- slurp the rest of the original makefile and copy it into the output
319 let slurp = do
320 l <- hGetLine hdl
321 hPutStrLn tmp_hdl l
322 slurp
323
324 catchIO slurp
325 (\e -> if isEOFError e then return () else ioError e)
326
327 hClose hdl
328
329 hClose tmp_hdl -- make sure it's flushed
330
331 -- Create a backup of the original makefile
332 when (isJust makefile_hdl)
333 (SysTools.copy dflags ("Backing up " ++ makefile)
334 makefile (makefile++".bak"))
335
336 -- Copy the new makefile in place
337 SysTools.copy dflags "Installing new makefile" tmp_file makefile
338
339
340 -----------------------------------------------------------------
341 -- Module cycles
342 -----------------------------------------------------------------
343
344 dumpModCycles :: DynFlags -> [ModSummary] -> IO ()
345 dumpModCycles dflags mod_summaries
346 | not (dopt Opt_D_dump_mod_cycles dflags)
347 = return ()
348
349 | null cycles
350 = putMsg dflags (ptext (sLit "No module cycles"))
351
352 | otherwise
353 = putMsg dflags (hang (ptext (sLit "Module cycles found:")) 2 pp_cycles)
354 where
355
356 cycles :: [[ModSummary]]
357 cycles = [ c | CyclicSCC c <- GHC.topSortModuleGraph True mod_summaries Nothing ]
358
359 pp_cycles = vcat [ (ptext (sLit "---------- Cycle") <+> int n <+> ptext (sLit "----------"))
360 $$ pprCycle c $$ blankLine
361 | (n,c) <- [1..] `zip` cycles ]
362
363 pprCycle :: [ModSummary] -> SDoc
364 -- Print a cycle, but show only the imports within the cycle
365 pprCycle summaries = pp_group (CyclicSCC summaries)
366 where
367 cycle_mods :: [ModuleName] -- The modules in this cycle
368 cycle_mods = map (moduleName . ms_mod) summaries
369
370 pp_group (AcyclicSCC ms) = pp_ms ms
371 pp_group (CyclicSCC mss)
372 = ASSERT( not (null boot_only) )
373 -- The boot-only list must be non-empty, else there would
374 -- be an infinite chain of non-boot imoprts, and we've
375 -- already checked for that in processModDeps
376 pp_ms loop_breaker $$ vcat (map pp_group groups)
377 where
378 (boot_only, others) = partition is_boot_only mss
379 is_boot_only ms = not (any in_group (map snd (ms_imps ms)))
380 in_group (L _ m) = m `elem` group_mods
381 group_mods = map (moduleName . ms_mod) mss
382
383 loop_breaker = head boot_only
384 all_others = tail boot_only ++ others
385 groups = GHC.topSortModuleGraph True all_others Nothing
386
387 pp_ms summary = text mod_str <> text (take (20 - length mod_str) (repeat ' '))
388 <+> (pp_imps empty (map snd (ms_imps summary)) $$
389 pp_imps (ptext (sLit "{-# SOURCE #-}")) (map snd (ms_srcimps summary)))
390 where
391 mod_str = moduleNameString (moduleName (ms_mod summary))
392
393 pp_imps :: SDoc -> [Located ModuleName] -> SDoc
394 pp_imps _ [] = empty
395 pp_imps what lms
396 = case [m | L _ m <- lms, m `elem` cycle_mods] of
397 [] -> empty
398 ms -> what <+> ptext (sLit "imports") <+>
399 pprWithCommas ppr ms
400
401 -----------------------------------------------------------------
402 --
403 -- Flags
404 --
405 -----------------------------------------------------------------
406
407 depStartMarker, depEndMarker :: String
408 depStartMarker = "# DO NOT DELETE: Beginning of Haskell dependencies"
409 depEndMarker = "# DO NOT DELETE: End of Haskell dependencies"
410