Replace uses of the old try function with the new one
[ghc.git] / compiler / main / GHC.hs
1 -- -----------------------------------------------------------------------------
2 --
3 -- (c) The University of Glasgow, 2005
4 --
5 -- The GHC API
6 --
7 -- -----------------------------------------------------------------------------
8
9 module GHC (
10 -- * Initialisation
11 defaultErrorHandler,
12 defaultCleanupHandler,
13
14 -- * GHC Monad
15 Ghc, GhcT, GhcMonad(..),
16 runGhc, runGhcT, initGhcMonad,
17 gcatch, gbracket, gfinally,
18 printException,
19 printExceptionAndWarnings,
20 handleSourceError,
21 needsTemplateHaskell,
22
23 -- * Flags and settings
24 DynFlags(..), DynFlag(..), Severity(..), HscTarget(..), dopt,
25 GhcMode(..), GhcLink(..), defaultObjectTarget,
26 parseDynamicFlags,
27 getSessionDynFlags,
28 setSessionDynFlags,
29 parseStaticFlags,
30
31 -- * Targets
32 Target(..), TargetId(..), Phase,
33 setTargets,
34 getTargets,
35 addTarget,
36 removeTarget,
37 guessTarget,
38
39 -- * Loading\/compiling the program
40 depanal,
41 load, LoadHowMuch(..),
42 SuccessFlag(..), succeeded, failed,
43 defaultWarnErrLogger, WarnErrLogger,
44 workingDirectoryChanged,
45 parseModule, typecheckModule, desugarModule, loadModule,
46 ParsedModule(..), TypecheckedModule(..), DesugaredModule(..),
47 TypecheckedSource, ParsedSource, RenamedSource, -- ditto
48 TypecheckedMod, ParsedMod,
49 moduleInfo, renamedSource, typecheckedSource,
50 parsedSource, coreModule,
51 compileToCoreModule, compileToCoreSimplified,
52 compileCoreToObj,
53 getModSummary,
54
55 -- * Inspecting the module structure of the program
56 ModuleGraph, ModSummary(..), ms_mod_name, ModLocation(..),
57 getModuleGraph,
58 isLoaded,
59 topSortModuleGraph,
60
61 -- * Inspecting modules
62 ModuleInfo,
63 getModuleInfo,
64 modInfoTyThings,
65 modInfoTopLevelScope,
66 modInfoExports,
67 modInfoInstances,
68 modInfoIsExportedName,
69 modInfoLookupName,
70 lookupGlobalName,
71 findGlobalAnns,
72 mkPrintUnqualifiedForModule,
73
74 -- * Querying the environment
75 packageDbModules,
76
77 -- * Printing
78 PrintUnqualified, alwaysQualify,
79
80 -- * Interactive evaluation
81 getBindings, getPrintUnqual,
82 findModule,
83 lookupModule,
84 #ifdef GHCI
85 setContext, getContext,
86 getNamesInScope,
87 getRdrNamesInScope,
88 getGRE,
89 moduleIsInterpreted,
90 getInfo,
91 exprType,
92 typeKind,
93 parseName,
94 RunResult(..),
95 runStmt, parseImportDecl, SingleStep(..),
96 resume,
97 Resume(resumeStmt, resumeThreadId, resumeBreakInfo, resumeSpan,
98 resumeHistory, resumeHistoryIx),
99 History(historyBreakInfo, historyEnclosingDecls),
100 GHC.getHistorySpan, getHistoryModule,
101 getResumeContext,
102 abandon, abandonAll,
103 InteractiveEval.back,
104 InteractiveEval.forward,
105 showModule,
106 isModuleInterpreted,
107 InteractiveEval.compileExpr, HValue, dynCompileExpr,
108 GHC.obtainTermFromId, GHC.obtainTermFromVal, reconstructType,
109 modInfoModBreaks,
110 ModBreaks(..), BreakIndex,
111 BreakInfo(breakInfo_number, breakInfo_module),
112 BreakArray, setBreakOn, setBreakOff, getBreak,
113 #endif
114 lookupName,
115
116 -- * Abstract syntax elements
117
118 -- ** Packages
119 PackageId,
120
121 -- ** Modules
122 Module, mkModule, pprModule, moduleName, modulePackageId,
123 ModuleName, mkModuleName, moduleNameString,
124
125 -- ** Names
126 Name,
127 isExternalName, nameModule, pprParenSymName, nameSrcSpan,
128 NamedThing(..),
129 RdrName(Qual,Unqual),
130
131 -- ** Identifiers
132 Id, idType,
133 isImplicitId, isDeadBinder,
134 isExportedId, isLocalId, isGlobalId,
135 isRecordSelector,
136 isPrimOpId, isFCallId, isClassOpId_maybe,
137 isDataConWorkId, idDataCon,
138 isBottomingId, isDictonaryId,
139 recordSelectorFieldLabel,
140
141 -- ** Type constructors
142 TyCon,
143 tyConTyVars, tyConDataCons, tyConArity,
144 isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon,
145 isFamilyTyCon,
146 synTyConDefn, synTyConType, synTyConResKind,
147
148 -- ** Type variables
149 TyVar,
150 alphaTyVars,
151
152 -- ** Data constructors
153 DataCon,
154 dataConSig, dataConType, dataConTyCon, dataConFieldLabels,
155 dataConIsInfix, isVanillaDataCon, dataConUserType,
156 dataConStrictMarks,
157 StrictnessMark(..), isMarkedStrict,
158
159 -- ** Classes
160 Class,
161 classMethods, classSCTheta, classTvsFds,
162 pprFundeps,
163
164 -- ** Instances
165 Instance,
166 instanceDFunId, pprInstance, pprInstanceHdr,
167
168 -- ** Types and Kinds
169 Type, splitForAllTys, funResultTy,
170 pprParendType, pprTypeApp,
171 Kind,
172 PredType,
173 ThetaType, pprForAll, pprThetaArrow,
174
175 -- ** Entities
176 TyThing(..),
177
178 -- ** Syntax
179 module HsSyn, -- ToDo: remove extraneous bits
180
181 -- ** Fixities
182 FixityDirection(..),
183 defaultFixity, maxPrecedence,
184 negateFixity,
185 compareFixity,
186
187 -- ** Source locations
188 SrcLoc, pprDefnLoc,
189 mkSrcLoc, isGoodSrcLoc, noSrcLoc,
190 srcLocFile, srcLocLine, srcLocCol,
191 SrcSpan,
192 mkSrcSpan, srcLocSpan, isGoodSrcSpan, noSrcSpan,
193 srcSpanStart, srcSpanEnd,
194 srcSpanFile,
195 srcSpanStartLine, srcSpanEndLine,
196 srcSpanStartCol, srcSpanEndCol,
197
198 -- ** Located
199 Located(..),
200
201 -- *** Constructing Located
202 noLoc, mkGeneralLocated,
203
204 -- *** Deconstructing Located
205 getLoc, unLoc,
206
207 -- *** Combining and comparing Located values
208 eqLocated, cmpLocated, combineLocs, addCLoc,
209 leftmost_smallest, leftmost_largest, rightmost,
210 spans, isSubspanOf,
211
212 -- * Exceptions
213 GhcException(..), showGhcException,
214
215 -- * Token stream manipulations
216 Token,
217 getTokenStream, getRichTokenStream,
218 showRichTokenStream, addSourceToTokens,
219
220 -- * Pure interface to the parser
221 parser,
222
223 -- * Miscellaneous
224 --sessionHscEnv,
225 cyclicModuleErr,
226 ) where
227
228 {-
229 ToDo:
230
231 * inline bits of HscMain here to simplify layering: hscTcExpr, hscStmt.
232 * what StaticFlags should we expose, if any?
233 -}
234
235 #include "HsVersions.h"
236
237 #ifdef GHCI
238 import qualified Linker
239 import Linker ( HValue )
240 import ByteCodeInstr
241 import BreakArray
242 import InteractiveEval
243 #endif
244
245 import GhcMonad
246 import TcIface
247 import TcRnTypes
248 import TcRnMonad ( initIfaceCheck )
249 import Packages
250 import NameSet
251 import RdrName
252 import qualified HsSyn -- hack as we want to reexport the whole module
253 import HsSyn hiding ((<.>))
254 import Type
255 import Coercion ( synTyConResKind )
256 import TcType hiding( typeKind )
257 import Id
258 import Var
259 import TysPrim ( alphaTyVars )
260 import TyCon
261 import Class
262 -- import FunDeps
263 import DataCon
264 import Name hiding ( varName )
265 -- import OccName ( parenSymOcc )
266 import InstEnv
267 import SrcLoc
268 import CoreSyn ( CoreBind )
269 import TidyPgm
270 import DriverPipeline
271 import DriverPhases ( Phase(..), isHaskellSrcFilename, startPhase )
272 import HeaderInfo
273 import Finder
274 import HscMain
275 import HscTypes
276 import DynFlags
277 import StaticFlagParser
278 import qualified StaticFlags
279 import SysTools ( initSysTools, cleanTempFiles, cleanTempFilesExcept,
280 cleanTempDirs )
281 import Annotations
282 import Module
283 import UniqFM
284 import Panic
285 import Digraph
286 import Bag ( unitBag, listToBag )
287 import ErrUtils
288 import MonadUtils
289 import Util
290 import StringBuffer
291 import Outputable
292 import BasicTypes
293 import Maybes ( expectJust, mapCatMaybes )
294 import FastString
295 import qualified Parser
296 import Lexer
297
298 import System.Directory ( getModificationTime, doesFileExist,
299 getCurrentDirectory )
300 import Data.Maybe
301 import Data.Map (Map)
302 import qualified Data.Map as Map
303 import qualified FiniteMap as Map
304 import Data.List
305 import qualified Data.List as List
306 import Data.Typeable ( Typeable )
307 import Data.Word ( Word8 )
308 import Control.Monad
309 import System.Exit ( exitWith, ExitCode(..) )
310 import System.Time ( ClockTime, getClockTime )
311 import Exception
312 import Data.IORef
313 import System.FilePath
314 import System.IO
315 import System.IO.Error ( isDoesNotExistError )
316 import Prelude hiding (init)
317
318
319 -- -----------------------------------------------------------------------------
320 -- Exception handlers
321
322 -- | Install some default exception handlers and run the inner computation.
323 -- Unless you want to handle exceptions yourself, you should wrap this around
324 -- the top level of your program. The default handlers output the error
325 -- message(s) to stderr and exit cleanly.
326 defaultErrorHandler :: (ExceptionMonad m, MonadIO m) => DynFlags -> m a -> m a
327 defaultErrorHandler dflags inner =
328 -- top-level exception handler: any unrecognised exception is a compiler bug.
329 ghandle (\exception -> liftIO $ do
330 hFlush stdout
331 case fromException exception of
332 -- an IO exception probably isn't our fault, so don't panic
333 Just (ioe :: IOException) ->
334 fatalErrorMsg dflags (text (show ioe))
335 _ -> case fromException exception of
336 Just UserInterrupt -> exitWith (ExitFailure 1)
337 Just StackOverflow ->
338 fatalErrorMsg dflags (text "stack overflow: use +RTS -K<size> to increase it")
339 _ -> case fromException exception of
340 Just (ex :: ExitCode) -> throw ex
341 _ ->
342 fatalErrorMsg dflags
343 (text (show (Panic (show exception))))
344 exitWith (ExitFailure 1)
345 ) $
346
347 -- error messages propagated as exceptions
348 handleGhcException
349 (\ge -> liftIO $ do
350 hFlush stdout
351 case ge of
352 PhaseFailed _ code -> exitWith code
353 Signal _ -> exitWith (ExitFailure 1)
354 _ -> do fatalErrorMsg dflags (text (show ge))
355 exitWith (ExitFailure 1)
356 ) $
357 inner
358
359 -- | Install a default cleanup handler to remove temporary files deposited by
360 -- a GHC run. This is seperate from 'defaultErrorHandler', because you might
361 -- want to override the error handling, but still get the ordinary cleanup
362 -- behaviour.
363 defaultCleanupHandler :: (ExceptionMonad m, MonadIO m) =>
364 DynFlags -> m a -> m a
365 defaultCleanupHandler dflags inner =
366 -- make sure we clean up after ourselves
367 inner `gfinally`
368 (liftIO $ do
369 cleanTempFiles dflags
370 cleanTempDirs dflags
371 )
372 -- exceptions will be blocked while we clean the temporary files,
373 -- so there shouldn't be any difficulty if we receive further
374 -- signals.
375
376 -- | Print the error message and all warnings. Useful inside exception
377 -- handlers. Clears warnings after printing.
378 printException :: GhcMonad m => SourceError -> m ()
379 printException err = do
380 dflags <- getSessionDynFlags
381 liftIO $ printBagOfErrors dflags (srcErrorMessages err)
382
383 {-# DEPRECATED printExceptionAndWarnings "use printException instead" #-}
384 printExceptionAndWarnings :: GhcMonad m => SourceError -> m ()
385 printExceptionAndWarnings = printException
386
387 -- | Run function for the 'Ghc' monad.
388 --
389 -- It initialises the GHC session and warnings via 'initGhcMonad'. Each call
390 -- to this function will create a new session which should not be shared among
391 -- several threads.
392 --
393 -- Any errors not handled inside the 'Ghc' action are propagated as IO
394 -- exceptions.
395
396 runGhc :: Maybe FilePath -- ^ See argument to 'initGhcMonad'.
397 -> Ghc a -- ^ The action to perform.
398 -> IO a
399 runGhc mb_top_dir ghc = do
400 ref <- newIORef undefined
401 let session = Session ref
402 flip unGhc session $ do
403 initGhcMonad mb_top_dir
404 ghc
405 -- XXX: unregister interrupt handlers here?
406
407 -- | Run function for 'GhcT' monad transformer.
408 --
409 -- It initialises the GHC session and warnings via 'initGhcMonad'. Each call
410 -- to this function will create a new session which should not be shared among
411 -- several threads.
412
413 runGhcT :: (ExceptionMonad m, Functor m, MonadIO m) =>
414 Maybe FilePath -- ^ See argument to 'initGhcMonad'.
415 -> GhcT m a -- ^ The action to perform.
416 -> m a
417 runGhcT mb_top_dir ghct = do
418 ref <- liftIO $ newIORef undefined
419 let session = Session ref
420 flip unGhcT session $ do
421 initGhcMonad mb_top_dir
422 ghct
423
424 -- | Initialise a GHC session.
425 --
426 -- If you implement a custom 'GhcMonad' you must call this function in the
427 -- monad run function. It will initialise the session variable and clear all
428 -- warnings.
429 --
430 -- The first argument should point to the directory where GHC's library files
431 -- reside. More precisely, this should be the output of @ghc --print-libdir@
432 -- of the version of GHC the module using this API is compiled with. For
433 -- portability, you should use the @ghc-paths@ package, available at
434 -- <http://hackage.haskell.org/cgi-bin/hackage-scripts/package/ghc-paths>.
435
436 initGhcMonad :: GhcMonad m => Maybe FilePath -> m ()
437 initGhcMonad mb_top_dir = do
438 -- catch ^C
439 liftIO $ installSignalHandlers
440
441 liftIO $ StaticFlags.initStaticOpts
442
443 dflags0 <- liftIO $ initDynFlags defaultDynFlags
444 dflags <- liftIO $ initSysTools mb_top_dir dflags0
445 env <- liftIO $ newHscEnv dflags
446 setSession env
447
448 -- -----------------------------------------------------------------------------
449 -- Flags & settings
450
451 -- | Updates the DynFlags in a Session. This also reads
452 -- the package database (unless it has already been read),
453 -- and prepares the compilers knowledge about packages. It
454 -- can be called again to load new packages: just add new
455 -- package flags to (packageFlags dflags).
456 --
457 -- Returns a list of new packages that may need to be linked in using
458 -- the dynamic linker (see 'linkPackages') as a result of new package
459 -- flags. If you are not doing linking or doing static linking, you
460 -- can ignore the list of packages returned.
461 --
462 setSessionDynFlags :: GhcMonad m => DynFlags -> m [PackageId]
463 setSessionDynFlags dflags = do
464 (dflags', preload) <- liftIO $ initPackages dflags
465 modifySession (\h -> h{ hsc_dflags = dflags' })
466 return preload
467
468 -- | If there is no -o option, guess the name of target executable
469 -- by using top-level source file name as a base.
470 guessOutputFile :: GhcMonad m => m ()
471 guessOutputFile = modifySession $ \env ->
472 let dflags = hsc_dflags env
473 mod_graph = hsc_mod_graph env
474 mainModuleSrcPath :: Maybe String
475 mainModuleSrcPath = do
476 let isMain = (== mainModIs dflags) . ms_mod
477 [ms] <- return (filter isMain mod_graph)
478 ml_hs_file (ms_location ms)
479 name = fmap dropExtension mainModuleSrcPath
480
481 #if defined(mingw32_HOST_OS)
482 -- we must add the .exe extention unconditionally here, otherwise
483 -- when name has an extension of its own, the .exe extension will
484 -- not be added by DriverPipeline.exeFileName. See #2248
485 name_exe = fmap (<.> "exe") name
486 #else
487 name_exe = name
488 #endif
489 in
490 case outputFile dflags of
491 Just _ -> env
492 Nothing -> env { hsc_dflags = dflags { outputFile = name_exe } }
493
494 -- -----------------------------------------------------------------------------
495 -- Targets
496
497 -- ToDo: think about relative vs. absolute file paths. And what
498 -- happens when the current directory changes.
499
500 -- | Sets the targets for this session. Each target may be a module name
501 -- or a filename. The targets correspond to the set of root modules for
502 -- the program\/library. Unloading the current program is achieved by
503 -- setting the current set of targets to be empty, followed by 'load'.
504 setTargets :: GhcMonad m => [Target] -> m ()
505 setTargets targets = modifySession (\h -> h{ hsc_targets = targets })
506
507 -- | Returns the current set of targets
508 getTargets :: GhcMonad m => m [Target]
509 getTargets = withSession (return . hsc_targets)
510
511 -- | Add another target.
512 addTarget :: GhcMonad m => Target -> m ()
513 addTarget target
514 = modifySession (\h -> h{ hsc_targets = target : hsc_targets h })
515
516 -- | Remove a target
517 removeTarget :: GhcMonad m => TargetId -> m ()
518 removeTarget target_id
519 = modifySession (\h -> h{ hsc_targets = filter (hsc_targets h) })
520 where
521 filter targets = [ t | t@(Target id _ _) <- targets, id /= target_id ]
522
523 -- | Attempts to guess what Target a string refers to. This function
524 -- implements the @--make@/GHCi command-line syntax for filenames:
525 --
526 -- - if the string looks like a Haskell source filename, then interpret it
527 -- as such
528 --
529 -- - if adding a .hs or .lhs suffix yields the name of an existing file,
530 -- then use that
531 --
532 -- - otherwise interpret the string as a module name
533 --
534 guessTarget :: GhcMonad m => String -> Maybe Phase -> m Target
535 guessTarget str (Just phase)
536 = return (Target (TargetFile str (Just phase)) True Nothing)
537 guessTarget str Nothing
538 | isHaskellSrcFilename file
539 = return (target (TargetFile file Nothing))
540 | otherwise
541 = do exists <- liftIO $ doesFileExist hs_file
542 if exists
543 then return (target (TargetFile hs_file Nothing))
544 else do
545 exists <- liftIO $ doesFileExist lhs_file
546 if exists
547 then return (target (TargetFile lhs_file Nothing))
548 else do
549 if looksLikeModuleName file
550 then return (target (TargetModule (mkModuleName file)))
551 else do
552 throwGhcException
553 (ProgramError (showSDoc $
554 text "target" <+> quotes (text file) <+>
555 text "is not a module name or a source file"))
556 where
557 (file,obj_allowed)
558 | '*':rest <- str = (rest, False)
559 | otherwise = (str, True)
560
561 hs_file = file <.> "hs"
562 lhs_file = file <.> "lhs"
563
564 target tid = Target tid obj_allowed Nothing
565
566 -- -----------------------------------------------------------------------------
567 -- Loading the program
568
569 -- | Perform a dependency analysis starting from the current targets
570 -- and update the session with the new module graph.
571 --
572 -- Dependency analysis entails parsing the @import@ directives and may
573 -- therefore require running certain preprocessors.
574 --
575 -- Note that each 'ModSummary' in the module graph caches its 'DynFlags'.
576 -- These 'DynFlags' are determined by the /current/ session 'DynFlags' and the
577 -- @OPTIONS@ and @LANGUAGE@ pragmas of the parsed module. Thus if you want to
578 -- changes to the 'DynFlags' to take effect you need to call this function
579 -- again.
580 --
581 depanal :: GhcMonad m =>
582 [ModuleName] -- ^ excluded modules
583 -> Bool -- ^ allow duplicate roots
584 -> m ModuleGraph
585 depanal excluded_mods allow_dup_roots = do
586 hsc_env <- getSession
587 let
588 dflags = hsc_dflags hsc_env
589 targets = hsc_targets hsc_env
590 old_graph = hsc_mod_graph hsc_env
591
592 liftIO $ showPass dflags "Chasing dependencies"
593 liftIO $ debugTraceMsg dflags 2 (hcat [
594 text "Chasing modules from: ",
595 hcat (punctuate comma (map pprTarget targets))])
596
597 mod_graph <- liftIO $ downsweep hsc_env old_graph excluded_mods allow_dup_roots
598 modifySession $ \_ -> hsc_env { hsc_mod_graph = mod_graph }
599 return mod_graph
600
601 -- | Describes which modules of the module graph need to be loaded.
602 data LoadHowMuch
603 = LoadAllTargets
604 -- ^ Load all targets and its dependencies.
605 | LoadUpTo ModuleName
606 -- ^ Load only the given module and its dependencies.
607 | LoadDependenciesOf ModuleName
608 -- ^ Load only the dependencies of the given module, but not the module
609 -- itself.
610
611 -- | Try to load the program. See 'LoadHowMuch' for the different modes.
612 --
613 -- This function implements the core of GHC's @--make@ mode. It preprocesses,
614 -- compiles and loads the specified modules, avoiding re-compilation wherever
615 -- possible. Depending on the target (see 'DynFlags.hscTarget') compilating
616 -- and loading may result in files being created on disk.
617 --
618 -- Calls the 'reportModuleCompilationResult' callback after each compiling
619 -- each module, whether successful or not.
620 --
621 -- Throw a 'SourceError' if errors are encountered before the actual
622 -- compilation starts (e.g., during dependency analysis). All other errors
623 -- are reported using the callback.
624 --
625 load :: GhcMonad m => LoadHowMuch -> m SuccessFlag
626 load how_much = do
627 mod_graph <- depanal [] False
628 load2 how_much mod_graph
629
630 -- | A function called to log warnings and errors.
631 type WarnErrLogger = GhcMonad m => Maybe SourceError -> m ()
632
633 defaultWarnErrLogger :: WarnErrLogger
634 defaultWarnErrLogger Nothing = return ()
635 defaultWarnErrLogger (Just e) = printException e
636
637 load2 :: GhcMonad m => LoadHowMuch -> [ModSummary]
638 -> m SuccessFlag
639 load2 how_much mod_graph = do
640 guessOutputFile
641 hsc_env <- getSession
642
643 let hpt1 = hsc_HPT hsc_env
644 let dflags = hsc_dflags hsc_env
645
646 -- The "bad" boot modules are the ones for which we have
647 -- B.hs-boot in the module graph, but no B.hs
648 -- The downsweep should have ensured this does not happen
649 -- (see msDeps)
650 let all_home_mods = [ms_mod_name s
651 | s <- mod_graph, not (isBootSummary s)]
652 bad_boot_mods = [s | s <- mod_graph, isBootSummary s,
653 not (ms_mod_name s `elem` all_home_mods)]
654 ASSERT( null bad_boot_mods ) return ()
655
656 -- check that the module given in HowMuch actually exists, otherwise
657 -- topSortModuleGraph will bomb later.
658 let checkHowMuch (LoadUpTo m) = checkMod m
659 checkHowMuch (LoadDependenciesOf m) = checkMod m
660 checkHowMuch _ = id
661
662 checkMod m and_then
663 | m `elem` all_home_mods = and_then
664 | otherwise = do
665 liftIO $ errorMsg dflags (text "no such module:" <+>
666 quotes (ppr m))
667 return Failed
668
669 checkHowMuch how_much $ do
670
671 -- mg2_with_srcimps drops the hi-boot nodes, returning a
672 -- graph with cycles. Among other things, it is used for
673 -- backing out partially complete cycles following a failed
674 -- upsweep, and for removing from hpt all the modules
675 -- not in strict downwards closure, during calls to compile.
676 let mg2_with_srcimps :: [SCC ModSummary]
677 mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing
678
679 -- If we can determine that any of the {-# SOURCE #-} imports
680 -- are definitely unnecessary, then emit a warning.
681 warnUnnecessarySourceImports mg2_with_srcimps
682
683 let
684 -- check the stability property for each module.
685 stable_mods@(stable_obj,stable_bco)
686 = checkStability hpt1 mg2_with_srcimps all_home_mods
687
688 -- prune bits of the HPT which are definitely redundant now,
689 -- to save space.
690 pruned_hpt = pruneHomePackageTable hpt1
691 (flattenSCCs mg2_with_srcimps)
692 stable_mods
693
694 _ <- liftIO $ evaluate pruned_hpt
695
696 -- before we unload anything, make sure we don't leave an old
697 -- interactive context around pointing to dead bindings. Also,
698 -- write the pruned HPT to allow the old HPT to be GC'd.
699 modifySession $ \_ -> hsc_env{ hsc_IC = emptyInteractiveContext,
700 hsc_HPT = pruned_hpt }
701
702 liftIO $ debugTraceMsg dflags 2 (text "Stable obj:" <+> ppr stable_obj $$
703 text "Stable BCO:" <+> ppr stable_bco)
704
705 -- Unload any modules which are going to be re-linked this time around.
706 let stable_linkables = [ linkable
707 | m <- stable_obj++stable_bco,
708 Just hmi <- [lookupUFM pruned_hpt m],
709 Just linkable <- [hm_linkable hmi] ]
710 liftIO $ unload hsc_env stable_linkables
711
712 -- We could at this point detect cycles which aren't broken by
713 -- a source-import, and complain immediately, but it seems better
714 -- to let upsweep_mods do this, so at least some useful work gets
715 -- done before the upsweep is abandoned.
716 --hPutStrLn stderr "after tsort:\n"
717 --hPutStrLn stderr (showSDoc (vcat (map ppr mg2)))
718
719 -- Now do the upsweep, calling compile for each module in
720 -- turn. Final result is version 3 of everything.
721
722 -- Topologically sort the module graph, this time including hi-boot
723 -- nodes, and possibly just including the portion of the graph
724 -- reachable from the module specified in the 2nd argument to load.
725 -- This graph should be cycle-free.
726 -- If we're restricting the upsweep to a portion of the graph, we
727 -- also want to retain everything that is still stable.
728 let full_mg :: [SCC ModSummary]
729 full_mg = topSortModuleGraph False mod_graph Nothing
730
731 maybe_top_mod = case how_much of
732 LoadUpTo m -> Just m
733 LoadDependenciesOf m -> Just m
734 _ -> Nothing
735
736 partial_mg0 :: [SCC ModSummary]
737 partial_mg0 = topSortModuleGraph False mod_graph maybe_top_mod
738
739 -- LoadDependenciesOf m: we want the upsweep to stop just
740 -- short of the specified module (unless the specified module
741 -- is stable).
742 partial_mg
743 | LoadDependenciesOf _mod <- how_much
744 = ASSERT( case last partial_mg0 of
745 AcyclicSCC ms -> ms_mod_name ms == _mod; _ -> False )
746 List.init partial_mg0
747 | otherwise
748 = partial_mg0
749
750 stable_mg =
751 [ AcyclicSCC ms
752 | AcyclicSCC ms <- full_mg,
753 ms_mod_name ms `elem` stable_obj++stable_bco,
754 ms_mod_name ms `notElem` [ ms_mod_name ms' |
755 AcyclicSCC ms' <- partial_mg ] ]
756
757 mg = stable_mg ++ partial_mg
758
759 -- clean up between compilations
760 let cleanup = cleanTempFilesExcept dflags
761 (ppFilesFromSummaries (flattenSCCs mg2_with_srcimps))
762
763 liftIO $ debugTraceMsg dflags 2 (hang (text "Ready for upsweep")
764 2 (ppr mg))
765
766 setSession hsc_env{ hsc_HPT = emptyHomePackageTable }
767 (upsweep_ok, modsUpswept)
768 <- upsweep pruned_hpt stable_mods cleanup mg
769
770 -- Make modsDone be the summaries for each home module now
771 -- available; this should equal the domain of hpt3.
772 -- Get in in a roughly top .. bottom order (hence reverse).
773
774 let modsDone = reverse modsUpswept
775
776 -- Try and do linking in some form, depending on whether the
777 -- upsweep was completely or only partially successful.
778
779 if succeeded upsweep_ok
780
781 then
782 -- Easy; just relink it all.
783 do liftIO $ debugTraceMsg dflags 2 (text "Upsweep completely successful.")
784
785 -- Clean up after ourselves
786 liftIO $ cleanTempFilesExcept dflags (ppFilesFromSummaries modsDone)
787
788 -- Issue a warning for the confusing case where the user
789 -- said '-o foo' but we're not going to do any linking.
790 -- We attempt linking if either (a) one of the modules is
791 -- called Main, or (b) the user said -no-hs-main, indicating
792 -- that main() is going to come from somewhere else.
793 --
794 let ofile = outputFile dflags
795 let no_hs_main = dopt Opt_NoHsMain dflags
796 let
797 main_mod = mainModIs dflags
798 a_root_is_Main = any ((==main_mod).ms_mod) mod_graph
799 do_linking = a_root_is_Main || no_hs_main || ghcLink dflags == LinkDynLib
800
801 when (ghcLink dflags == LinkBinary
802 && isJust ofile && not do_linking) $
803 liftIO $ debugTraceMsg dflags 1 $
804 text ("Warning: output was redirected with -o, " ++
805 "but no output will be generated\n" ++
806 "because there is no " ++
807 moduleNameString (moduleName main_mod) ++ " module.")
808
809 -- link everything together
810 hsc_env1 <- getSession
811 linkresult <- liftIO $ link (ghcLink dflags) dflags do_linking (hsc_HPT hsc_env1)
812
813 loadFinish Succeeded linkresult
814
815 else
816 -- Tricky. We need to back out the effects of compiling any
817 -- half-done cycles, both so as to clean up the top level envs
818 -- and to avoid telling the interactive linker to link them.
819 do liftIO $ debugTraceMsg dflags 2 (text "Upsweep partially successful.")
820
821 let modsDone_names
822 = map ms_mod modsDone
823 let mods_to_zap_names
824 = findPartiallyCompletedCycles modsDone_names
825 mg2_with_srcimps
826 let mods_to_keep
827 = filter ((`notElem` mods_to_zap_names).ms_mod)
828 modsDone
829
830 hsc_env1 <- getSession
831 let hpt4 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep)
832 (hsc_HPT hsc_env1)
833
834 -- Clean up after ourselves
835 liftIO $ cleanTempFilesExcept dflags (ppFilesFromSummaries mods_to_keep)
836
837 -- there should be no Nothings where linkables should be, now
838 ASSERT(all (isJust.hm_linkable)
839 (eltsUFM (hsc_HPT hsc_env))) do
840
841 -- Link everything together
842 linkresult <- liftIO $ link (ghcLink dflags) dflags False hpt4
843
844 modifySession $ \hsc_env -> hsc_env{ hsc_HPT = hpt4 }
845 loadFinish Failed linkresult
846
847 -- Finish up after a load.
848
849 -- If the link failed, unload everything and return.
850 loadFinish :: GhcMonad m =>
851 SuccessFlag -> SuccessFlag
852 -> m SuccessFlag
853 loadFinish _all_ok Failed
854 = do hsc_env <- getSession
855 liftIO $ unload hsc_env []
856 modifySession discardProg
857 return Failed
858
859 -- Empty the interactive context and set the module context to the topmost
860 -- newly loaded module, or the Prelude if none were loaded.
861 loadFinish all_ok Succeeded
862 = do modifySession $ \hsc_env -> hsc_env{ hsc_IC = emptyInteractiveContext }
863 return all_ok
864
865
866 -- Forget the current program, but retain the persistent info in HscEnv
867 discardProg :: HscEnv -> HscEnv
868 discardProg hsc_env
869 = hsc_env { hsc_mod_graph = emptyMG,
870 hsc_IC = emptyInteractiveContext,
871 hsc_HPT = emptyHomePackageTable }
872
873 -- used to fish out the preprocess output files for the purposes of
874 -- cleaning up. The preprocessed file *might* be the same as the
875 -- source file, but that doesn't do any harm.
876 ppFilesFromSummaries :: [ModSummary] -> [FilePath]
877 ppFilesFromSummaries summaries = map ms_hspp_file summaries
878
879 -- -----------------------------------------------------------------------------
880
881 class ParsedMod m where
882 modSummary :: m -> ModSummary
883 parsedSource :: m -> ParsedSource
884
885 class ParsedMod m => TypecheckedMod m where
886 renamedSource :: m -> Maybe RenamedSource
887 typecheckedSource :: m -> TypecheckedSource
888 moduleInfo :: m -> ModuleInfo
889 tm_internals :: m -> (TcGblEnv, ModDetails)
890 -- ToDo: improvements that could be made here:
891 -- if the module succeeded renaming but not typechecking,
892 -- we can still get back the GlobalRdrEnv and exports, so
893 -- perhaps the ModuleInfo should be split up into separate
894 -- fields.
895
896 class TypecheckedMod m => DesugaredMod m where
897 coreModule :: m -> ModGuts
898
899 -- | The result of successful parsing.
900 data ParsedModule =
901 ParsedModule { pm_mod_summary :: ModSummary
902 , pm_parsed_source :: ParsedSource }
903
904 instance ParsedMod ParsedModule where
905 modSummary m = pm_mod_summary m
906 parsedSource m = pm_parsed_source m
907
908 -- | The result of successful typechecking. It also contains the parser
909 -- result.
910 data TypecheckedModule =
911 TypecheckedModule { tm_parsed_module :: ParsedModule
912 , tm_renamed_source :: Maybe RenamedSource
913 , tm_typechecked_source :: TypecheckedSource
914 , tm_checked_module_info :: ModuleInfo
915 , tm_internals_ :: (TcGblEnv, ModDetails)
916 }
917
918 instance ParsedMod TypecheckedModule where
919 modSummary m = modSummary (tm_parsed_module m)
920 parsedSource m = parsedSource (tm_parsed_module m)
921
922 instance TypecheckedMod TypecheckedModule where
923 renamedSource m = tm_renamed_source m
924 typecheckedSource m = tm_typechecked_source m
925 moduleInfo m = tm_checked_module_info m
926 tm_internals m = tm_internals_ m
927
928 -- | The result of successful desugaring (i.e., translation to core). Also
929 -- contains all the information of a typechecked module.
930 data DesugaredModule =
931 DesugaredModule { dm_typechecked_module :: TypecheckedModule
932 , dm_core_module :: ModGuts
933 }
934
935 instance ParsedMod DesugaredModule where
936 modSummary m = modSummary (dm_typechecked_module m)
937 parsedSource m = parsedSource (dm_typechecked_module m)
938
939 instance TypecheckedMod DesugaredModule where
940 renamedSource m = renamedSource (dm_typechecked_module m)
941 typecheckedSource m = typecheckedSource (dm_typechecked_module m)
942 moduleInfo m = moduleInfo (dm_typechecked_module m)
943 tm_internals m = tm_internals_ (dm_typechecked_module m)
944
945 instance DesugaredMod DesugaredModule where
946 coreModule m = dm_core_module m
947
948 type ParsedSource = Located (HsModule RdrName)
949 type RenamedSource = (HsGroup Name, [LImportDecl Name], Maybe [LIE Name],
950 Maybe LHsDocString)
951 type TypecheckedSource = LHsBinds Id
952
953 -- NOTE:
954 -- - things that aren't in the output of the typechecker right now:
955 -- - the export list
956 -- - the imports
957 -- - type signatures
958 -- - type/data/newtype declarations
959 -- - class declarations
960 -- - instances
961 -- - extra things in the typechecker's output:
962 -- - default methods are turned into top-level decls.
963 -- - dictionary bindings
964
965 -- | Return the 'ModSummary' of a module with the given name.
966 --
967 -- The module must be part of the module graph (see 'hsc_mod_graph' and
968 -- 'ModuleGraph'). If this is not the case, this function will throw a
969 -- 'GhcApiError'.
970 --
971 -- This function ignores boot modules and requires that there is only one
972 -- non-boot module with the given name.
973 getModSummary :: GhcMonad m => ModuleName -> m ModSummary
974 getModSummary mod = do
975 mg <- liftM hsc_mod_graph getSession
976 case [ ms | ms <- mg, ms_mod_name ms == mod, not (isBootSummary ms) ] of
977 [] -> throw $ mkApiErr (text "Module not part of module graph")
978 [ms] -> return ms
979 multiple -> throw $ mkApiErr (text "getModSummary is ambiguous: " <+> ppr multiple)
980
981 -- | Parse a module.
982 --
983 -- Throws a 'SourceError' on parse error.
984 parseModule :: GhcMonad m => ModSummary -> m ParsedModule
985 parseModule ms = do
986 hsc_env <- getSession
987 let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }
988 rdr_module <- liftIO $ hscParse hsc_env_tmp ms
989 return (ParsedModule ms rdr_module)
990
991 -- | Typecheck and rename a parsed module.
992 --
993 -- Throws a 'SourceError' if either fails.
994 typecheckModule :: GhcMonad m => ParsedModule -> m TypecheckedModule
995 typecheckModule pmod = do
996 let ms = modSummary pmod
997 hsc_env <- getSession
998 let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }
999 (tc_gbl_env, rn_info)
1000 <- liftIO $ hscTypecheckRename hsc_env_tmp ms (parsedSource pmod)
1001 details <- liftIO $ makeSimpleDetails hsc_env_tmp tc_gbl_env
1002 return $
1003 TypecheckedModule {
1004 tm_internals_ = (tc_gbl_env, details),
1005 tm_parsed_module = pmod,
1006 tm_renamed_source = rn_info,
1007 tm_typechecked_source = tcg_binds tc_gbl_env,
1008 tm_checked_module_info =
1009 ModuleInfo {
1010 minf_type_env = md_types details,
1011 minf_exports = availsToNameSet $ md_exports details,
1012 minf_rdr_env = Just (tcg_rdr_env tc_gbl_env),
1013 minf_instances = md_insts details
1014 #ifdef GHCI
1015 ,minf_modBreaks = emptyModBreaks
1016 #endif
1017 }}
1018
1019 -- | Desugar a typechecked module.
1020 desugarModule :: GhcMonad m => TypecheckedModule -> m DesugaredModule
1021 desugarModule tcm = do
1022 let ms = modSummary tcm
1023 let (tcg, _) = tm_internals tcm
1024 hsc_env <- getSession
1025 let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }
1026 guts <- liftIO $ hscDesugar hsc_env_tmp ms tcg
1027 return $
1028 DesugaredModule {
1029 dm_typechecked_module = tcm,
1030 dm_core_module = guts
1031 }
1032
1033 -- | Load a module. Input doesn't need to be desugared.
1034 --
1035 -- A module must be loaded before dependent modules can be typechecked. This
1036 -- always includes generating a 'ModIface' and, depending on the
1037 -- 'DynFlags.hscTarget', may also include code generation.
1038 --
1039 -- This function will always cause recompilation and will always overwrite
1040 -- previous compilation results (potentially files on disk).
1041 --
1042 loadModule :: (TypecheckedMod mod, GhcMonad m) => mod -> m mod
1043 loadModule tcm = do
1044 let ms = modSummary tcm
1045 let mod = ms_mod_name ms
1046 let loc = ms_location ms
1047 let (tcg, _details) = tm_internals tcm
1048
1049 mb_linkable <- case ms_obj_date ms of
1050 Just t | t > ms_hs_date ms -> do
1051 l <- liftIO $ findObjectLinkable (ms_mod ms)
1052 (ml_obj_file loc) t
1053 return (Just l)
1054 _otherwise -> return Nothing
1055
1056 -- compile doesn't change the session
1057 hsc_env <- getSession
1058 mod_info <- liftIO $ compile' (hscNothingBackendOnly tcg,
1059 hscInteractiveBackendOnly tcg,
1060 hscBatchBackendOnly tcg)
1061 hsc_env ms 1 1 Nothing mb_linkable
1062
1063 modifySession $ \e -> e{ hsc_HPT = addToUFM (hsc_HPT e) mod mod_info }
1064 return tcm
1065
1066 -- -----------------------------------------------------------------------------
1067 -- Operations dealing with Core
1068
1069 -- | A CoreModule consists of just the fields of a 'ModGuts' that are needed for
1070 -- the 'GHC.compileToCoreModule' interface.
1071 data CoreModule
1072 = CoreModule {
1073 -- | Module name
1074 cm_module :: !Module,
1075 -- | Type environment for types declared in this module
1076 cm_types :: !TypeEnv,
1077 -- | Declarations
1078 cm_binds :: [CoreBind],
1079 -- | Imports
1080 cm_imports :: ![Module]
1081 }
1082
1083 instance Outputable CoreModule where
1084 ppr (CoreModule {cm_module = mn, cm_types = te, cm_binds = cb}) =
1085 text "%module" <+> ppr mn <+> ppr te $$ vcat (map ppr cb)
1086
1087 -- | This is the way to get access to the Core bindings corresponding
1088 -- to a module. 'compileToCore' parses, typechecks, and
1089 -- desugars the module, then returns the resulting Core module (consisting of
1090 -- the module name, type declarations, and function declarations) if
1091 -- successful.
1092 compileToCoreModule :: GhcMonad m => FilePath -> m CoreModule
1093 compileToCoreModule = compileCore False
1094
1095 -- | Like compileToCoreModule, but invokes the simplifier, so
1096 -- as to return simplified and tidied Core.
1097 compileToCoreSimplified :: GhcMonad m => FilePath -> m CoreModule
1098 compileToCoreSimplified = compileCore True
1099 {-
1100 -- | Provided for backwards-compatibility: compileToCore returns just the Core
1101 -- bindings, but for most purposes, you probably want to call
1102 -- compileToCoreModule.
1103 compileToCore :: GhcMonad m => FilePath -> m [CoreBind]
1104 compileToCore fn = do
1105 mod <- compileToCoreModule session fn
1106 return $ cm_binds mod
1107 -}
1108 -- | Takes a CoreModule and compiles the bindings therein
1109 -- to object code. The first argument is a bool flag indicating
1110 -- whether to run the simplifier.
1111 -- The resulting .o, .hi, and executable files, if any, are stored in the
1112 -- current directory, and named according to the module name.
1113 -- This has only so far been tested with a single self-contained module.
1114 compileCoreToObj :: GhcMonad m => Bool -> CoreModule -> m ()
1115 compileCoreToObj simplify cm@(CoreModule{ cm_module = mName }) = do
1116 dflags <- getSessionDynFlags
1117 currentTime <- liftIO $ getClockTime
1118 cwd <- liftIO $ getCurrentDirectory
1119 modLocation <- liftIO $ mkHiOnlyModLocation dflags (hiSuf dflags) cwd
1120 ((moduleNameSlashes . moduleName) mName)
1121
1122 let modSummary = ModSummary { ms_mod = mName,
1123 ms_hsc_src = ExtCoreFile,
1124 ms_location = modLocation,
1125 -- By setting the object file timestamp to Nothing,
1126 -- we always force recompilation, which is what we
1127 -- want. (Thus it doesn't matter what the timestamp
1128 -- for the (nonexistent) source file is.)
1129 ms_hs_date = currentTime,
1130 ms_obj_date = Nothing,
1131 -- Only handling the single-module case for now, so no imports.
1132 ms_srcimps = [],
1133 ms_imps = [],
1134 -- No source file
1135 ms_hspp_file = "",
1136 ms_hspp_opts = dflags,
1137 ms_hspp_buf = Nothing
1138 }
1139
1140 hsc_env <- getSession
1141 liftIO $ hscCompileCore hsc_env simplify modSummary (cm_binds cm)
1142
1143
1144 compileCore :: GhcMonad m => Bool -> FilePath -> m CoreModule
1145 compileCore simplify fn = do
1146 -- First, set the target to the desired filename
1147 target <- guessTarget fn Nothing
1148 addTarget target
1149 _ <- load LoadAllTargets
1150 -- Then find dependencies
1151 modGraph <- depanal [] True
1152 case find ((== fn) . msHsFilePath) modGraph of
1153 Just modSummary -> do
1154 -- Now we have the module name;
1155 -- parse, typecheck and desugar the module
1156 mod_guts <- coreModule `fmap`
1157 -- TODO: space leaky: call hsc* directly?
1158 (desugarModule =<< typecheckModule =<< parseModule modSummary)
1159 liftM gutsToCoreModule $
1160 if simplify
1161 then do
1162 -- If simplify is true: simplify (hscSimplify), then tidy
1163 -- (tidyProgram).
1164 hsc_env <- getSession
1165 simpl_guts <- liftIO $ hscSimplify hsc_env mod_guts
1166 tidy_guts <- liftIO $ tidyProgram hsc_env simpl_guts
1167 return $ Left tidy_guts
1168 else
1169 return $ Right mod_guts
1170
1171 Nothing -> panic "compileToCoreModule: target FilePath not found in\
1172 module dependency graph"
1173 where -- two versions, based on whether we simplify (thus run tidyProgram,
1174 -- which returns a (CgGuts, ModDetails) pair, or not (in which case
1175 -- we just have a ModGuts.
1176 gutsToCoreModule :: Either (CgGuts, ModDetails) ModGuts -> CoreModule
1177 gutsToCoreModule (Left (cg, md)) = CoreModule {
1178 cm_module = cg_module cg, cm_types = md_types md,
1179 cm_imports = cg_dir_imps cg, cm_binds = cg_binds cg
1180 }
1181 gutsToCoreModule (Right mg) = CoreModule {
1182 cm_module = mg_module mg, cm_types = mg_types mg,
1183 cm_imports = moduleEnvKeys (mg_dir_imps mg), cm_binds = mg_binds mg
1184 }
1185
1186 -- ---------------------------------------------------------------------------
1187 -- Unloading
1188
1189 unload :: HscEnv -> [Linkable] -> IO ()
1190 unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables'
1191 = case ghcLink (hsc_dflags hsc_env) of
1192 #ifdef GHCI
1193 LinkInMemory -> Linker.unload (hsc_dflags hsc_env) stable_linkables
1194 #else
1195 LinkInMemory -> panic "unload: no interpreter"
1196 -- urgh. avoid warnings:
1197 hsc_env stable_linkables
1198 #endif
1199 _other -> return ()
1200
1201 -- -----------------------------------------------------------------------------
1202
1203 {- |
1204
1205 Stability tells us which modules definitely do not need to be recompiled.
1206 There are two main reasons for having stability:
1207
1208 - avoid doing a complete upsweep of the module graph in GHCi when
1209 modules near the bottom of the tree have not changed.
1210
1211 - to tell GHCi when it can load object code: we can only load object code
1212 for a module when we also load object code fo all of the imports of the
1213 module. So we need to know that we will definitely not be recompiling
1214 any of these modules, and we can use the object code.
1215
1216 The stability check is as follows. Both stableObject and
1217 stableBCO are used during the upsweep phase later.
1218
1219 @
1220 stable m = stableObject m || stableBCO m
1221
1222 stableObject m =
1223 all stableObject (imports m)
1224 && old linkable does not exist, or is == on-disk .o
1225 && date(on-disk .o) > date(.hs)
1226
1227 stableBCO m =
1228 all stable (imports m)
1229 && date(BCO) > date(.hs)
1230 @
1231
1232 These properties embody the following ideas:
1233
1234 - if a module is stable, then:
1235
1236 - if it has been compiled in a previous pass (present in HPT)
1237 then it does not need to be compiled or re-linked.
1238
1239 - if it has not been compiled in a previous pass,
1240 then we only need to read its .hi file from disk and
1241 link it to produce a 'ModDetails'.
1242
1243 - if a modules is not stable, we will definitely be at least
1244 re-linking, and possibly re-compiling it during the 'upsweep'.
1245 All non-stable modules can (and should) therefore be unlinked
1246 before the 'upsweep'.
1247
1248 - Note that objects are only considered stable if they only depend
1249 on other objects. We can't link object code against byte code.
1250 -}
1251
1252 checkStability
1253 :: HomePackageTable -- HPT from last compilation
1254 -> [SCC ModSummary] -- current module graph (cyclic)
1255 -> [ModuleName] -- all home modules
1256 -> ([ModuleName], -- stableObject
1257 [ModuleName]) -- stableBCO
1258
1259 checkStability hpt sccs all_home_mods = foldl checkSCC ([],[]) sccs
1260 where
1261 checkSCC (stable_obj, stable_bco) scc0
1262 | stableObjects = (scc_mods ++ stable_obj, stable_bco)
1263 | stableBCOs = (stable_obj, scc_mods ++ stable_bco)
1264 | otherwise = (stable_obj, stable_bco)
1265 where
1266 scc = flattenSCC scc0
1267 scc_mods = map ms_mod_name scc
1268 home_module m = m `elem` all_home_mods && m `notElem` scc_mods
1269
1270 scc_allimps = nub (filter home_module (concatMap ms_home_allimps scc))
1271 -- all imports outside the current SCC, but in the home pkg
1272
1273 stable_obj_imps = map (`elem` stable_obj) scc_allimps
1274 stable_bco_imps = map (`elem` stable_bco) scc_allimps
1275
1276 stableObjects =
1277 and stable_obj_imps
1278 && all object_ok scc
1279
1280 stableBCOs =
1281 and (zipWith (||) stable_obj_imps stable_bco_imps)
1282 && all bco_ok scc
1283
1284 object_ok ms
1285 | Just t <- ms_obj_date ms = t >= ms_hs_date ms
1286 && same_as_prev t
1287 | otherwise = False
1288 where
1289 same_as_prev t = case lookupUFM hpt (ms_mod_name ms) of
1290 Just hmi | Just l <- hm_linkable hmi
1291 -> isObjectLinkable l && t == linkableTime l
1292 _other -> True
1293 -- why '>=' rather than '>' above? If the filesystem stores
1294 -- times to the nearset second, we may occasionally find that
1295 -- the object & source have the same modification time,
1296 -- especially if the source was automatically generated
1297 -- and compiled. Using >= is slightly unsafe, but it matches
1298 -- make's behaviour.
1299
1300 bco_ok ms
1301 = case lookupUFM hpt (ms_mod_name ms) of
1302 Just hmi | Just l <- hm_linkable hmi ->
1303 not (isObjectLinkable l) &&
1304 linkableTime l >= ms_hs_date ms
1305 _other -> False
1306
1307 -- -----------------------------------------------------------------------------
1308
1309 -- | Prune the HomePackageTable
1310 --
1311 -- Before doing an upsweep, we can throw away:
1312 --
1313 -- - For non-stable modules:
1314 -- - all ModDetails, all linked code
1315 -- - all unlinked code that is out of date with respect to
1316 -- the source file
1317 --
1318 -- This is VERY IMPORTANT otherwise we'll end up requiring 2x the
1319 -- space at the end of the upsweep, because the topmost ModDetails of the
1320 -- old HPT holds on to the entire type environment from the previous
1321 -- compilation.
1322
1323 pruneHomePackageTable
1324 :: HomePackageTable
1325 -> [ModSummary]
1326 -> ([ModuleName],[ModuleName])
1327 -> HomePackageTable
1328
1329 pruneHomePackageTable hpt summ (stable_obj, stable_bco)
1330 = mapUFM prune hpt
1331 where prune hmi
1332 | is_stable modl = hmi'
1333 | otherwise = hmi'{ hm_details = emptyModDetails }
1334 where
1335 modl = moduleName (mi_module (hm_iface hmi))
1336 hmi' | Just l <- hm_linkable hmi, linkableTime l < ms_hs_date ms
1337 = hmi{ hm_linkable = Nothing }
1338 | otherwise
1339 = hmi
1340 where ms = expectJust "prune" (lookupUFM ms_map modl)
1341
1342 ms_map = listToUFM [(ms_mod_name ms, ms) | ms <- summ]
1343
1344 is_stable m = m `elem` stable_obj || m `elem` stable_bco
1345
1346 -- -----------------------------------------------------------------------------
1347
1348 -- Return (names of) all those in modsDone who are part of a cycle
1349 -- as defined by theGraph.
1350 findPartiallyCompletedCycles :: [Module] -> [SCC ModSummary] -> [Module]
1351 findPartiallyCompletedCycles modsDone theGraph
1352 = chew theGraph
1353 where
1354 chew [] = []
1355 chew ((AcyclicSCC _):rest) = chew rest -- acyclic? not interesting.
1356 chew ((CyclicSCC vs):rest)
1357 = let names_in_this_cycle = nub (map ms_mod vs)
1358 mods_in_this_cycle
1359 = nub ([done | done <- modsDone,
1360 done `elem` names_in_this_cycle])
1361 chewed_rest = chew rest
1362 in
1363 if notNull mods_in_this_cycle
1364 && length mods_in_this_cycle < length names_in_this_cycle
1365 then mods_in_this_cycle ++ chewed_rest
1366 else chewed_rest
1367
1368 -- -----------------------------------------------------------------------------
1369
1370 -- | The upsweep
1371 --
1372 -- This is where we compile each module in the module graph, in a pass
1373 -- from the bottom to the top of the graph.
1374 --
1375 -- There better had not be any cyclic groups here -- we check for them.
1376
1377 upsweep
1378 :: GhcMonad m
1379 => HomePackageTable -- ^ HPT from last time round (pruned)
1380 -> ([ModuleName],[ModuleName]) -- ^ stable modules (see checkStability)
1381 -> IO () -- ^ How to clean up unwanted tmp files
1382 -> [SCC ModSummary] -- ^ Mods to do (the worklist)
1383 -> m (SuccessFlag,
1384 [ModSummary])
1385 -- ^ Returns:
1386 --
1387 -- 1. A flag whether the complete upsweep was successful.
1388 -- 2. The 'HscEnv' in the monad has an updated HPT
1389 -- 3. A list of modules which succeeded loading.
1390
1391 upsweep old_hpt stable_mods cleanup sccs = do
1392 (res, done) <- upsweep' old_hpt [] sccs 1 (length sccs)
1393 return (res, reverse done)
1394 where
1395
1396 upsweep' _old_hpt done
1397 [] _ _
1398 = return (Succeeded, done)
1399
1400 upsweep' _old_hpt done
1401 (CyclicSCC ms:_) _ _
1402 = do dflags <- getSessionDynFlags
1403 liftIO $ fatalErrorMsg dflags (cyclicModuleErr ms)
1404 return (Failed, done)
1405
1406 upsweep' old_hpt done
1407 (AcyclicSCC mod:mods) mod_index nmods
1408 = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++
1409 -- show (map (moduleUserString.moduleName.mi_module.hm_iface)
1410 -- (moduleEnvElts (hsc_HPT hsc_env)))
1411 let logger _mod = defaultWarnErrLogger
1412
1413 hsc_env <- getSession
1414 mb_mod_info
1415 <- handleSourceError
1416 (\err -> do logger mod (Just err); return Nothing) $ do
1417 mod_info <- liftIO $ upsweep_mod hsc_env old_hpt stable_mods
1418 mod mod_index nmods
1419 logger mod Nothing -- log warnings
1420 return (Just mod_info)
1421
1422 liftIO cleanup -- Remove unwanted tmp files between compilations
1423
1424 case mb_mod_info of
1425 Nothing -> return (Failed, done)
1426 Just mod_info -> do
1427 let this_mod = ms_mod_name mod
1428
1429 -- Add new info to hsc_env
1430 hpt1 = addToUFM (hsc_HPT hsc_env) this_mod mod_info
1431 hsc_env1 = hsc_env { hsc_HPT = hpt1 }
1432
1433 -- Space-saving: delete the old HPT entry
1434 -- for mod BUT if mod is a hs-boot
1435 -- node, don't delete it. For the
1436 -- interface, the HPT entry is probaby for the
1437 -- main Haskell source file. Deleting it
1438 -- would force the real module to be recompiled
1439 -- every time.
1440 old_hpt1 | isBootSummary mod = old_hpt
1441 | otherwise = delFromUFM old_hpt this_mod
1442
1443 done' = mod:done
1444
1445 -- fixup our HomePackageTable after we've finished compiling
1446 -- a mutually-recursive loop. See reTypecheckLoop, below.
1447 hsc_env2 <- liftIO $ reTypecheckLoop hsc_env1 mod done'
1448 setSession hsc_env2
1449
1450 upsweep' old_hpt1 done' mods (mod_index+1) nmods
1451
1452 -- | Compile a single module. Always produce a Linkable for it if
1453 -- successful. If no compilation happened, return the old Linkable.
1454 upsweep_mod :: HscEnv
1455 -> HomePackageTable
1456 -> ([ModuleName],[ModuleName])
1457 -> ModSummary
1458 -> Int -- index of module
1459 -> Int -- total number of modules
1460 -> IO HomeModInfo
1461
1462 upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods
1463 = let
1464 this_mod_name = ms_mod_name summary
1465 this_mod = ms_mod summary
1466 mb_obj_date = ms_obj_date summary
1467 obj_fn = ml_obj_file (ms_location summary)
1468 hs_date = ms_hs_date summary
1469
1470 is_stable_obj = this_mod_name `elem` stable_obj
1471 is_stable_bco = this_mod_name `elem` stable_bco
1472
1473 old_hmi = lookupUFM old_hpt this_mod_name
1474
1475 -- We're using the dflags for this module now, obtained by
1476 -- applying any options in its LANGUAGE & OPTIONS_GHC pragmas.
1477 dflags = ms_hspp_opts summary
1478 prevailing_target = hscTarget (hsc_dflags hsc_env)
1479 local_target = hscTarget dflags
1480
1481 -- If OPTIONS_GHC contains -fasm or -fvia-C, be careful that
1482 -- we don't do anything dodgy: these should only work to change
1483 -- from -fvia-C to -fasm and vice-versa, otherwise we could
1484 -- end up trying to link object code to byte code.
1485 target = if prevailing_target /= local_target
1486 && (not (isObjectTarget prevailing_target)
1487 || not (isObjectTarget local_target))
1488 then prevailing_target
1489 else local_target
1490
1491 -- store the corrected hscTarget into the summary
1492 summary' = summary{ ms_hspp_opts = dflags { hscTarget = target } }
1493
1494 -- The old interface is ok if
1495 -- a) we're compiling a source file, and the old HPT
1496 -- entry is for a source file
1497 -- b) we're compiling a hs-boot file
1498 -- Case (b) allows an hs-boot file to get the interface of its
1499 -- real source file on the second iteration of the compilation
1500 -- manager, but that does no harm. Otherwise the hs-boot file
1501 -- will always be recompiled
1502
1503 mb_old_iface
1504 = case old_hmi of
1505 Nothing -> Nothing
1506 Just hm_info | isBootSummary summary -> Just iface
1507 | not (mi_boot iface) -> Just iface
1508 | otherwise -> Nothing
1509 where
1510 iface = hm_iface hm_info
1511
1512 compile_it :: Maybe Linkable -> IO HomeModInfo
1513 compile_it mb_linkable =
1514 compile hsc_env summary' mod_index nmods
1515 mb_old_iface mb_linkable
1516
1517 compile_it_discard_iface :: Maybe Linkable -> IO HomeModInfo
1518 compile_it_discard_iface mb_linkable =
1519 compile hsc_env summary' mod_index nmods
1520 Nothing mb_linkable
1521
1522 -- With the HscNothing target we create empty linkables to avoid
1523 -- recompilation. We have to detect these to recompile anyway if
1524 -- the target changed since the last compile.
1525 is_fake_linkable
1526 | Just hmi <- old_hmi, Just l <- hm_linkable hmi =
1527 null (linkableUnlinked l)
1528 | otherwise =
1529 -- we have no linkable, so it cannot be fake
1530 False
1531
1532 implies False _ = True
1533 implies True x = x
1534
1535 in
1536 case () of
1537 _
1538 -- Regardless of whether we're generating object code or
1539 -- byte code, we can always use an existing object file
1540 -- if it is *stable* (see checkStability).
1541 | is_stable_obj, Just hmi <- old_hmi -> do
1542 liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
1543 (text "skipping stable obj mod:" <+> ppr this_mod_name)
1544 return hmi
1545 -- object is stable, and we have an entry in the
1546 -- old HPT: nothing to do
1547
1548 | is_stable_obj, isNothing old_hmi -> do
1549 liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
1550 (text "compiling stable on-disk mod:" <+> ppr this_mod_name)
1551 linkable <- liftIO $ findObjectLinkable this_mod obj_fn
1552 (expectJust "upsweep1" mb_obj_date)
1553 compile_it (Just linkable)
1554 -- object is stable, but we need to load the interface
1555 -- off disk to make a HMI.
1556
1557 | not (isObjectTarget target), is_stable_bco,
1558 (target /= HscNothing) `implies` not is_fake_linkable ->
1559 ASSERT(isJust old_hmi) -- must be in the old_hpt
1560 let Just hmi = old_hmi in do
1561 liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
1562 (text "skipping stable BCO mod:" <+> ppr this_mod_name)
1563 return hmi
1564 -- BCO is stable: nothing to do
1565
1566 | not (isObjectTarget target),
1567 Just hmi <- old_hmi,
1568 Just l <- hm_linkable hmi,
1569 not (isObjectLinkable l),
1570 (target /= HscNothing) `implies` not is_fake_linkable,
1571 linkableTime l >= ms_hs_date summary -> do
1572 liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
1573 (text "compiling non-stable BCO mod:" <+> ppr this_mod_name)
1574 compile_it (Just l)
1575 -- we have an old BCO that is up to date with respect
1576 -- to the source: do a recompilation check as normal.
1577
1578 -- When generating object code, if there's an up-to-date
1579 -- object file on the disk, then we can use it.
1580 -- However, if the object file is new (compared to any
1581 -- linkable we had from a previous compilation), then we
1582 -- must discard any in-memory interface, because this
1583 -- means the user has compiled the source file
1584 -- separately and generated a new interface, that we must
1585 -- read from the disk.
1586 --
1587 | isObjectTarget target,
1588 Just obj_date <- mb_obj_date,
1589 obj_date >= hs_date -> do
1590 case old_hmi of
1591 Just hmi
1592 | Just l <- hm_linkable hmi,
1593 isObjectLinkable l && linkableTime l == obj_date -> do
1594 liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
1595 (text "compiling mod with new on-disk obj:" <+> ppr this_mod_name)
1596 compile_it (Just l)
1597 _otherwise -> do
1598 liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
1599 (text "compiling mod with new on-disk obj2:" <+> ppr this_mod_name)
1600 linkable <- liftIO $ findObjectLinkable this_mod obj_fn obj_date
1601 compile_it_discard_iface (Just linkable)
1602
1603 _otherwise -> do
1604 liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
1605 (text "compiling mod:" <+> ppr this_mod_name)
1606 compile_it Nothing
1607
1608
1609
1610 -- Filter modules in the HPT
1611 retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable
1612 retainInTopLevelEnvs keep_these hpt
1613 = listToUFM [ (mod, expectJust "retain" mb_mod_info)
1614 | mod <- keep_these
1615 , let mb_mod_info = lookupUFM hpt mod
1616 , isJust mb_mod_info ]
1617
1618 -- ---------------------------------------------------------------------------
1619 -- Typecheck module loops
1620
1621 {-
1622 See bug #930. This code fixes a long-standing bug in --make. The
1623 problem is that when compiling the modules *inside* a loop, a data
1624 type that is only defined at the top of the loop looks opaque; but
1625 after the loop is done, the structure of the data type becomes
1626 apparent.
1627
1628 The difficulty is then that two different bits of code have
1629 different notions of what the data type looks like.
1630
1631 The idea is that after we compile a module which also has an .hs-boot
1632 file, we re-generate the ModDetails for each of the modules that
1633 depends on the .hs-boot file, so that everyone points to the proper
1634 TyCons, Ids etc. defined by the real module, not the boot module.
1635 Fortunately re-generating a ModDetails from a ModIface is easy: the
1636 function TcIface.typecheckIface does exactly that.
1637
1638 Picking the modules to re-typecheck is slightly tricky. Starting from
1639 the module graph consisting of the modules that have already been
1640 compiled, we reverse the edges (so they point from the imported module
1641 to the importing module), and depth-first-search from the .hs-boot
1642 node. This gives us all the modules that depend transitively on the
1643 .hs-boot module, and those are exactly the modules that we need to
1644 re-typecheck.
1645
1646 Following this fix, GHC can compile itself with --make -O2.
1647 -}
1648
1649 reTypecheckLoop :: HscEnv -> ModSummary -> ModuleGraph -> IO HscEnv
1650 reTypecheckLoop hsc_env ms graph
1651 | not (isBootSummary ms) &&
1652 any (\m -> ms_mod m == this_mod && isBootSummary m) graph
1653 = do
1654 let mss = reachableBackwards (ms_mod_name ms) graph
1655 non_boot = filter (not.isBootSummary) mss
1656 debugTraceMsg (hsc_dflags hsc_env) 2 $
1657 text "Re-typechecking loop: " <> ppr (map ms_mod_name non_boot)
1658 typecheckLoop hsc_env (map ms_mod_name non_boot)
1659 | otherwise
1660 = return hsc_env
1661 where
1662 this_mod = ms_mod ms
1663
1664 typecheckLoop :: HscEnv -> [ModuleName] -> IO HscEnv
1665 typecheckLoop hsc_env mods = do
1666 new_hpt <-
1667 fixIO $ \new_hpt -> do
1668 let new_hsc_env = hsc_env{ hsc_HPT = new_hpt }
1669 mds <- initIfaceCheck new_hsc_env $
1670 mapM (typecheckIface . hm_iface) hmis
1671 let new_hpt = addListToUFM old_hpt
1672 (zip mods [ hmi{ hm_details = details }
1673 | (hmi,details) <- zip hmis mds ])
1674 return new_hpt
1675 return hsc_env{ hsc_HPT = new_hpt }
1676 where
1677 old_hpt = hsc_HPT hsc_env
1678 hmis = map (expectJust "typecheckLoop" . lookupUFM old_hpt) mods
1679
1680 reachableBackwards :: ModuleName -> [ModSummary] -> [ModSummary]
1681 reachableBackwards mod summaries
1682 = [ ms | (ms,_,_) <- reachableG (transposeG graph) root ]
1683 where -- the rest just sets up the graph:
1684 (graph, lookup_node) = moduleGraphNodes False summaries
1685 root = expectJust "reachableBackwards" (lookup_node HsBootFile mod)
1686
1687 -- ---------------------------------------------------------------------------
1688 -- Topological sort of the module graph
1689
1690 type SummaryNode = (ModSummary, Int, [Int])
1691
1692 topSortModuleGraph
1693 :: Bool
1694 -- ^ Drop hi-boot nodes? (see below)
1695 -> [ModSummary]
1696 -> Maybe ModuleName
1697 -- ^ Root module name. If @Nothing@, use the full graph.
1698 -> [SCC ModSummary]
1699 -- ^ Calculate SCCs of the module graph, possibly dropping the hi-boot nodes
1700 -- The resulting list of strongly-connected-components is in topologically
1701 -- sorted order, starting with the module(s) at the bottom of the
1702 -- dependency graph (ie compile them first) and ending with the ones at
1703 -- the top.
1704 --
1705 -- Drop hi-boot nodes (first boolean arg)?
1706 --
1707 -- - @False@: treat the hi-boot summaries as nodes of the graph,
1708 -- so the graph must be acyclic
1709 --
1710 -- - @True@: eliminate the hi-boot nodes, and instead pretend
1711 -- the a source-import of Foo is an import of Foo
1712 -- The resulting graph has no hi-boot nodes, but can be cyclic
1713
1714 topSortModuleGraph drop_hs_boot_nodes summaries mb_root_mod
1715 = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph
1716 where
1717 (graph, lookup_node) = moduleGraphNodes drop_hs_boot_nodes summaries
1718
1719 initial_graph = case mb_root_mod of
1720 Nothing -> graph
1721 Just root_mod ->
1722 -- restrict the graph to just those modules reachable from
1723 -- the specified module. We do this by building a graph with
1724 -- the full set of nodes, and determining the reachable set from
1725 -- the specified node.
1726 let root | Just node <- lookup_node HsSrcFile root_mod, graph `hasVertexG` node = node
1727 | otherwise = ghcError (ProgramError "module does not exist")
1728 in graphFromEdgedVertices (seq root (reachableG graph root))
1729
1730 summaryNodeKey :: SummaryNode -> Int
1731 summaryNodeKey (_, k, _) = k
1732
1733 summaryNodeSummary :: SummaryNode -> ModSummary
1734 summaryNodeSummary (s, _, _) = s
1735
1736 moduleGraphNodes :: Bool -> [ModSummary]
1737 -> (Graph SummaryNode, HscSource -> ModuleName -> Maybe SummaryNode)
1738 moduleGraphNodes drop_hs_boot_nodes summaries = (graphFromEdgedVertices nodes, lookup_node)
1739 where
1740 numbered_summaries = zip summaries [1..]
1741
1742 lookup_node :: HscSource -> ModuleName -> Maybe SummaryNode
1743 lookup_node hs_src mod = Map.lookup (mod, hs_src) node_map
1744
1745 lookup_key :: HscSource -> ModuleName -> Maybe Int
1746 lookup_key hs_src mod = fmap summaryNodeKey (lookup_node hs_src mod)
1747
1748 node_map :: NodeMap SummaryNode
1749 node_map = Map.fromList [ ((moduleName (ms_mod s), ms_hsc_src s), node)
1750 | node@(s, _, _) <- nodes ]
1751
1752 -- We use integers as the keys for the SCC algorithm
1753 nodes :: [SummaryNode]
1754 nodes = [ (s, key, out_keys)
1755 | (s, key) <- numbered_summaries
1756 -- Drop the hi-boot ones if told to do so
1757 , not (isBootSummary s && drop_hs_boot_nodes)
1758 , let out_keys = out_edge_keys hs_boot_key (map unLoc (ms_home_srcimps s)) ++
1759 out_edge_keys HsSrcFile (map unLoc (ms_home_imps s)) ++
1760 (-- see [boot-edges] below
1761 if drop_hs_boot_nodes || ms_hsc_src s == HsBootFile
1762 then []
1763 else case lookup_key HsBootFile (ms_mod_name s) of
1764 Nothing -> []
1765 Just k -> [k]) ]
1766
1767 -- [boot-edges] if this is a .hs and there is an equivalent
1768 -- .hs-boot, add a link from the former to the latter. This
1769 -- has the effect of detecting bogus cases where the .hs-boot
1770 -- depends on the .hs, by introducing a cycle. Additionally,
1771 -- it ensures that we will always process the .hs-boot before
1772 -- the .hs, and so the HomePackageTable will always have the
1773 -- most up to date information.
1774
1775 -- Drop hs-boot nodes by using HsSrcFile as the key
1776 hs_boot_key | drop_hs_boot_nodes = HsSrcFile
1777 | otherwise = HsBootFile
1778
1779 out_edge_keys :: HscSource -> [ModuleName] -> [Int]
1780 out_edge_keys hi_boot ms = mapCatMaybes (lookup_key hi_boot) ms
1781 -- If we want keep_hi_boot_nodes, then we do lookup_key with
1782 -- the IsBootInterface parameter True; else False
1783
1784
1785 type NodeKey = (ModuleName, HscSource) -- The nodes of the graph are
1786 type NodeMap a = Map NodeKey a -- keyed by (mod, src_file_type) pairs
1787
1788 msKey :: ModSummary -> NodeKey
1789 msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot }) = (moduleName mod,boot)
1790
1791 mkNodeMap :: [ModSummary] -> NodeMap ModSummary
1792 mkNodeMap summaries = Map.fromList [ (msKey s, s) | s <- summaries]
1793
1794 nodeMapElts :: NodeMap a -> [a]
1795 nodeMapElts = Map.elems
1796
1797 -- | If there are {-# SOURCE #-} imports between strongly connected
1798 -- components in the topological sort, then those imports can
1799 -- definitely be replaced by ordinary non-SOURCE imports: if SOURCE
1800 -- were necessary, then the edge would be part of a cycle.
1801 warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m ()
1802 warnUnnecessarySourceImports sccs = do
1803 logWarnings (listToBag (concatMap (check.flattenSCC) sccs))
1804 where check ms =
1805 let mods_in_this_cycle = map ms_mod_name ms in
1806 [ warn i | m <- ms, i <- ms_home_srcimps m,
1807 unLoc i `notElem` mods_in_this_cycle ]
1808
1809 warn :: Located ModuleName -> WarnMsg
1810 warn (L loc mod) =
1811 mkPlainErrMsg loc
1812 (ptext (sLit "Warning: {-# SOURCE #-} unnecessary in import of ")
1813 <+> quotes (ppr mod))
1814
1815 -----------------------------------------------------------------------------
1816 -- Downsweep (dependency analysis)
1817
1818 -- Chase downwards from the specified root set, returning summaries
1819 -- for all home modules encountered. Only follow source-import
1820 -- links.
1821
1822 -- We pass in the previous collection of summaries, which is used as a
1823 -- cache to avoid recalculating a module summary if the source is
1824 -- unchanged.
1825 --
1826 -- The returned list of [ModSummary] nodes has one node for each home-package
1827 -- module, plus one for any hs-boot files. The imports of these nodes
1828 -- are all there, including the imports of non-home-package modules.
1829
1830 downsweep :: HscEnv
1831 -> [ModSummary] -- Old summaries
1832 -> [ModuleName] -- Ignore dependencies on these; treat
1833 -- them as if they were package modules
1834 -> Bool -- True <=> allow multiple targets to have
1835 -- the same module name; this is
1836 -- very useful for ghc -M
1837 -> IO [ModSummary]
1838 -- The elts of [ModSummary] all have distinct
1839 -- (Modules, IsBoot) identifiers, unless the Bool is true
1840 -- in which case there can be repeats
1841 downsweep hsc_env old_summaries excl_mods allow_dup_roots
1842 = do
1843 rootSummaries <- mapM getRootSummary roots
1844 let root_map = mkRootMap rootSummaries
1845 checkDuplicates root_map
1846 summs <- loop (concatMap msDeps rootSummaries) root_map
1847 return summs
1848 where
1849 roots = hsc_targets hsc_env
1850
1851 old_summary_map :: NodeMap ModSummary
1852 old_summary_map = mkNodeMap old_summaries
1853
1854 getRootSummary :: Target -> IO ModSummary
1855 getRootSummary (Target (TargetFile file mb_phase) obj_allowed maybe_buf)
1856 = do exists <- liftIO $ doesFileExist file
1857 if exists
1858 then summariseFile hsc_env old_summaries file mb_phase
1859 obj_allowed maybe_buf
1860 else throwOneError $ mkPlainErrMsg noSrcSpan $
1861 text "can't find file:" <+> text file
1862 getRootSummary (Target (TargetModule modl) obj_allowed maybe_buf)
1863 = do maybe_summary <- summariseModule hsc_env old_summary_map False
1864 (L rootLoc modl) obj_allowed
1865 maybe_buf excl_mods
1866 case maybe_summary of
1867 Nothing -> packageModErr modl
1868 Just s -> return s
1869
1870 rootLoc = mkGeneralSrcSpan (fsLit "<command line>")
1871
1872 -- In a root module, the filename is allowed to diverge from the module
1873 -- name, so we have to check that there aren't multiple root files
1874 -- defining the same module (otherwise the duplicates will be silently
1875 -- ignored, leading to confusing behaviour).
1876 checkDuplicates :: NodeMap [ModSummary] -> IO ()
1877 checkDuplicates root_map
1878 | allow_dup_roots = return ()
1879 | null dup_roots = return ()
1880 | otherwise = liftIO $ multiRootsErr (head dup_roots)
1881 where
1882 dup_roots :: [[ModSummary]] -- Each at least of length 2
1883 dup_roots = filterOut isSingleton (nodeMapElts root_map)
1884
1885 loop :: [(Located ModuleName,IsBootInterface)]
1886 -- Work list: process these modules
1887 -> NodeMap [ModSummary]
1888 -- Visited set; the range is a list because
1889 -- the roots can have the same module names
1890 -- if allow_dup_roots is True
1891 -> IO [ModSummary]
1892 -- The result includes the worklist, except
1893 -- for those mentioned in the visited set
1894 loop [] done = return (concat (nodeMapElts done))
1895 loop ((wanted_mod, is_boot) : ss) done
1896 | Just summs <- Map.lookup key done
1897 = if isSingleton summs then
1898 loop ss done
1899 else
1900 do { multiRootsErr summs; return [] }
1901 | otherwise
1902 = do mb_s <- summariseModule hsc_env old_summary_map
1903 is_boot wanted_mod True
1904 Nothing excl_mods
1905 case mb_s of
1906 Nothing -> loop ss done
1907 Just s -> loop (msDeps s ++ ss) (Map.insert key [s] done)
1908 where
1909 key = (unLoc wanted_mod, if is_boot then HsBootFile else HsSrcFile)
1910
1911 -- XXX Does the (++) here need to be flipped?
1912 mkRootMap :: [ModSummary] -> NodeMap [ModSummary]
1913 mkRootMap summaries = Map.insertListWith (flip (++))
1914 [ (msKey s, [s]) | s <- summaries ]
1915 Map.empty
1916
1917 msDeps :: ModSummary -> [(Located ModuleName, IsBootInterface)]
1918 -- (msDeps s) returns the dependencies of the ModSummary s.
1919 -- A wrinkle is that for a {-# SOURCE #-} import we return
1920 -- *both* the hs-boot file
1921 -- *and* the source file
1922 -- as "dependencies". That ensures that the list of all relevant
1923 -- modules always contains B.hs if it contains B.hs-boot.
1924 -- Remember, this pass isn't doing the topological sort. It's
1925 -- just gathering the list of all relevant ModSummaries
1926 msDeps s =
1927 concat [ [(m,True), (m,False)] | m <- ms_home_srcimps s ]
1928 ++ [ (m,False) | m <- ms_home_imps s ]
1929
1930 home_imps :: [Located (ImportDecl RdrName)] -> [Located ModuleName]
1931 home_imps imps = [ ideclName i | L _ i <- imps, isLocal (ideclPkgQual i) ]
1932 where isLocal Nothing = True
1933 isLocal (Just pkg) | pkg == fsLit "this" = True -- "this" is special
1934 isLocal _ = False
1935
1936 ms_home_allimps :: ModSummary -> [ModuleName]
1937 ms_home_allimps ms = map unLoc (ms_home_srcimps ms ++ ms_home_imps ms)
1938
1939 ms_home_srcimps :: ModSummary -> [Located ModuleName]
1940 ms_home_srcimps = home_imps . ms_srcimps
1941
1942 ms_home_imps :: ModSummary -> [Located ModuleName]
1943 ms_home_imps = home_imps . ms_imps
1944
1945 -----------------------------------------------------------------------------
1946 -- Summarising modules
1947
1948 -- We have two types of summarisation:
1949 --
1950 -- * Summarise a file. This is used for the root module(s) passed to
1951 -- cmLoadModules. The file is read, and used to determine the root
1952 -- module name. The module name may differ from the filename.
1953 --
1954 -- * Summarise a module. We are given a module name, and must provide
1955 -- a summary. The finder is used to locate the file in which the module
1956 -- resides.
1957
1958 summariseFile
1959 :: HscEnv
1960 -> [ModSummary] -- old summaries
1961 -> FilePath -- source file name
1962 -> Maybe Phase -- start phase
1963 -> Bool -- object code allowed?
1964 -> Maybe (StringBuffer,ClockTime)
1965 -> IO ModSummary
1966
1967 summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf
1968 -- we can use a cached summary if one is available and the
1969 -- source file hasn't changed, But we have to look up the summary
1970 -- by source file, rather than module name as we do in summarise.
1971 | Just old_summary <- findSummaryBySourceFile old_summaries file
1972 = do
1973 let location = ms_location old_summary
1974
1975 -- return the cached summary if the source didn't change
1976 src_timestamp <- case maybe_buf of
1977 Just (_,t) -> return t
1978 Nothing -> liftIO $ getModificationTime file
1979 -- The file exists; we checked in getRootSummary above.
1980 -- If it gets removed subsequently, then this
1981 -- getModificationTime may fail, but that's the right
1982 -- behaviour.
1983
1984 if ms_hs_date old_summary == src_timestamp
1985 then do -- update the object-file timestamp
1986 obj_timestamp <-
1987 if isObjectTarget (hscTarget (hsc_dflags hsc_env))
1988 || obj_allowed -- bug #1205
1989 then liftIO $ getObjTimestamp location False
1990 else return Nothing
1991 return old_summary{ ms_obj_date = obj_timestamp }
1992 else
1993 new_summary
1994
1995 | otherwise
1996 = new_summary
1997 where
1998 new_summary = do
1999 let dflags = hsc_dflags hsc_env
2000
2001 (dflags', hspp_fn, buf)
2002 <- preprocessFile hsc_env file mb_phase maybe_buf
2003
2004 (srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn file
2005
2006 -- Make a ModLocation for this file
2007 location <- liftIO $ mkHomeModLocation dflags mod_name file
2008
2009 -- Tell the Finder cache where it is, so that subsequent calls
2010 -- to findModule will find it, even if it's not on any search path
2011 mod <- liftIO $ addHomeModuleToFinder hsc_env mod_name location
2012
2013 src_timestamp <- case maybe_buf of
2014 Just (_,t) -> return t
2015 Nothing -> liftIO $ getModificationTime file
2016 -- getMofificationTime may fail
2017
2018 -- when the user asks to load a source file by name, we only
2019 -- use an object file if -fobject-code is on. See #1205.
2020 obj_timestamp <-
2021 if isObjectTarget (hscTarget (hsc_dflags hsc_env))
2022 || obj_allowed -- bug #1205
2023 then liftIO $ modificationTimeIfExists (ml_obj_file location)
2024 else return Nothing
2025
2026 return (ModSummary { ms_mod = mod, ms_hsc_src = HsSrcFile,
2027 ms_location = location,
2028 ms_hspp_file = hspp_fn,
2029 ms_hspp_opts = dflags',
2030 ms_hspp_buf = Just buf,
2031 ms_srcimps = srcimps, ms_imps = the_imps,
2032 ms_hs_date = src_timestamp,
2033 ms_obj_date = obj_timestamp })
2034
2035 findSummaryBySourceFile :: [ModSummary] -> FilePath -> Maybe ModSummary
2036 findSummaryBySourceFile summaries file
2037 = case [ ms | ms <- summaries, HsSrcFile <- [ms_hsc_src ms],
2038 expectJust "findSummaryBySourceFile" (ml_hs_file (ms_location ms)) == file ] of
2039 [] -> Nothing
2040 (x:_) -> Just x
2041
2042 -- Summarise a module, and pick up source and timestamp.
2043 summariseModule
2044 :: HscEnv
2045 -> NodeMap ModSummary -- Map of old summaries
2046 -> IsBootInterface -- True <=> a {-# SOURCE #-} import
2047 -> Located ModuleName -- Imported module to be summarised
2048 -> Bool -- object code allowed?
2049 -> Maybe (StringBuffer, ClockTime)
2050 -> [ModuleName] -- Modules to exclude
2051 -> IO (Maybe ModSummary) -- Its new summary
2052
2053 summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
2054 obj_allowed maybe_buf excl_mods
2055 | wanted_mod `elem` excl_mods
2056 = return Nothing
2057
2058 | Just old_summary <- Map.lookup (wanted_mod, hsc_src) old_summary_map
2059 = do -- Find its new timestamp; all the
2060 -- ModSummaries in the old map have valid ml_hs_files
2061 let location = ms_location old_summary
2062 src_fn = expectJust "summariseModule" (ml_hs_file location)
2063
2064 -- check the modification time on the source file, and
2065 -- return the cached summary if it hasn't changed. If the
2066 -- file has disappeared, we need to call the Finder again.
2067 case maybe_buf of
2068 Just (_,t) -> check_timestamp old_summary location src_fn t
2069 Nothing -> do
2070 m <- tryIO (getModificationTime src_fn)
2071 case m of
2072 Right t -> check_timestamp old_summary location src_fn t
2073 Left e | isDoesNotExistError e -> find_it
2074 | otherwise -> ioError e
2075
2076 | otherwise = find_it
2077 where
2078 dflags = hsc_dflags hsc_env
2079
2080 hsc_src = if is_boot then HsBootFile else HsSrcFile
2081
2082 check_timestamp old_summary location src_fn src_timestamp
2083 | ms_hs_date old_summary == src_timestamp = do
2084 -- update the object-file timestamp
2085 obj_timestamp <-
2086 if isObjectTarget (hscTarget (hsc_dflags hsc_env))
2087 || obj_allowed -- bug #1205
2088 then getObjTimestamp location is_boot
2089 else return Nothing
2090 return (Just old_summary{ ms_obj_date = obj_timestamp })
2091 | otherwise =
2092 -- source changed: re-summarise.
2093 new_summary location (ms_mod old_summary) src_fn src_timestamp
2094
2095 find_it = do
2096 -- Don't use the Finder's cache this time. If the module was
2097 -- previously a package module, it may have now appeared on the
2098 -- search path, so we want to consider it to be a home module. If
2099 -- the module was previously a home module, it may have moved.
2100 uncacheModule hsc_env wanted_mod
2101 found <- findImportedModule hsc_env wanted_mod Nothing
2102 case found of
2103 Found location mod
2104 | isJust (ml_hs_file location) ->
2105 -- Home package
2106 just_found location mod
2107 | otherwise ->
2108 -- Drop external-pkg
2109 ASSERT(modulePackageId mod /= thisPackage dflags)
2110 return Nothing
2111
2112 err -> noModError dflags loc wanted_mod err
2113 -- Not found
2114
2115 just_found location mod = do
2116 -- Adjust location to point to the hs-boot source file,
2117 -- hi file, object file, when is_boot says so
2118 let location' | is_boot = addBootSuffixLocn location
2119 | otherwise = location
2120 src_fn = expectJust "summarise2" (ml_hs_file location')
2121
2122 -- Check that it exists
2123 -- It might have been deleted since the Finder last found it
2124 maybe_t <- modificationTimeIfExists src_fn
2125 case maybe_t of
2126 Nothing -> noHsFileErr loc src_fn
2127 Just t -> new_summary location' mod src_fn t
2128
2129
2130 new_summary location mod src_fn src_timestamp
2131 = do
2132 -- Preprocess the source file and get its imports
2133 -- The dflags' contains the OPTIONS pragmas
2134 (dflags', hspp_fn, buf) <- preprocessFile hsc_env src_fn Nothing maybe_buf
2135 (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn src_fn
2136
2137 when (mod_name /= wanted_mod) $
2138 throwOneError $ mkPlainErrMsg mod_loc $
2139 text "File name does not match module name:"
2140 $$ text "Saw:" <+> quotes (ppr mod_name)
2141 $$ text "Expected:" <+> quotes (ppr wanted_mod)
2142
2143 -- Find the object timestamp, and return the summary
2144 obj_timestamp <-
2145 if isObjectTarget (hscTarget (hsc_dflags hsc_env))
2146 || obj_allowed -- bug #1205
2147 then getObjTimestamp location is_boot
2148 else return Nothing
2149
2150 return (Just (ModSummary { ms_mod = mod,
2151 ms_hsc_src = hsc_src,
2152 ms_location = location,
2153 ms_hspp_file = hspp_fn,
2154 ms_hspp_opts = dflags',
2155 ms_hspp_buf = Just buf,
2156 ms_srcimps = srcimps,
2157 ms_imps = the_imps,
2158 ms_hs_date = src_timestamp,
2159 ms_obj_date = obj_timestamp }))
2160
2161
2162 getObjTimestamp :: ModLocation -> Bool -> IO (Maybe ClockTime)
2163 getObjTimestamp location is_boot
2164 = if is_boot then return Nothing
2165 else modificationTimeIfExists (ml_obj_file location)
2166
2167
2168 preprocessFile :: HscEnv
2169 -> FilePath
2170 -> Maybe Phase -- ^ Starting phase
2171 -> Maybe (StringBuffer,ClockTime)
2172 -> IO (DynFlags, FilePath, StringBuffer)
2173 preprocessFile hsc_env src_fn mb_phase Nothing
2174 = do
2175 (dflags', hspp_fn) <- preprocess hsc_env (src_fn, mb_phase)
2176 buf <- hGetStringBuffer hspp_fn
2177 return (dflags', hspp_fn, buf)
2178
2179 preprocessFile hsc_env src_fn mb_phase (Just (buf, _time))
2180 = do
2181 let dflags = hsc_dflags hsc_env
2182 -- case we bypass the preprocessing stage?
2183 let
2184 local_opts = getOptions dflags buf src_fn
2185 --
2186 (dflags', leftovers, warns)
2187 <- parseDynamicNoPackageFlags dflags local_opts
2188 checkProcessArgsResult leftovers
2189 handleFlagWarnings dflags' warns
2190
2191 let
2192 needs_preprocessing
2193 | Just (Unlit _) <- mb_phase = True
2194 | Nothing <- mb_phase, Unlit _ <- startPhase src_fn = True
2195 -- note: local_opts is only required if there's no Unlit phase
2196 | xopt Opt_Cpp dflags' = True
2197 | dopt Opt_Pp dflags' = True
2198 | otherwise = False
2199
2200 when needs_preprocessing $
2201 ghcError (ProgramError "buffer needs preprocesing; interactive check disabled")
2202
2203 return (dflags', src_fn, buf)
2204
2205
2206 -----------------------------------------------------------------------------
2207 -- Error messages
2208 -----------------------------------------------------------------------------
2209
2210 noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> IO ab
2211 -- ToDo: we don't have a proper line number for this error
2212 noModError dflags loc wanted_mod err
2213 = throwOneError $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err
2214
2215 noHsFileErr :: SrcSpan -> String -> IO a
2216 noHsFileErr loc path
2217 = throwOneError $ mkPlainErrMsg loc $ text "Can't find" <+> text path
2218
2219 packageModErr :: ModuleName -> IO a
2220 packageModErr mod
2221 = throwOneError $ mkPlainErrMsg noSrcSpan $
2222 text "module" <+> quotes (ppr mod) <+> text "is a package module"
2223
2224 multiRootsErr :: [ModSummary] -> IO ()
2225 multiRootsErr [] = panic "multiRootsErr"
2226 multiRootsErr summs@(summ1:_)
2227 = throwOneError $ mkPlainErrMsg noSrcSpan $
2228 text "module" <+> quotes (ppr mod) <+>
2229 text "is defined in multiple files:" <+>
2230 sep (map text files)
2231 where
2232 mod = ms_mod summ1
2233 files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs
2234
2235 cyclicModuleErr :: [ModSummary] -> SDoc
2236 cyclicModuleErr ms
2237 = hang (ptext (sLit "Module imports form a cycle for modules:"))
2238 2 (vcat (map show_one ms))
2239 where
2240 mods_in_cycle = map ms_mod_name ms
2241 imp_modname = unLoc . ideclName . unLoc
2242 just_in_cycle = filter ((`elem` mods_in_cycle) . imp_modname)
2243
2244 show_one ms =
2245 vcat [ show_mod (ms_hsc_src ms) (ms_mod_name ms) <+>
2246 maybe empty (parens . text) (ml_hs_file (ms_location ms)),
2247 nest 2 $ ptext (sLit "imports:") <+> vcat [
2248 pp_imps HsBootFile (just_in_cycle $ ms_srcimps ms),
2249 pp_imps HsSrcFile (just_in_cycle $ ms_imps ms) ]
2250 ]
2251 show_mod hsc_src mod = ppr mod <> text (hscSourceString hsc_src)
2252 pp_imps src imps = fsep (map (show_mod src . unLoc . ideclName . unLoc) imps)
2253
2254
2255 -- | Inform GHC that the working directory has changed. GHC will flush
2256 -- its cache of module locations, since it may no longer be valid.
2257 --
2258 -- Note: Before changing the working directory make sure all threads running
2259 -- in the same session have stopped. If you change the working directory,
2260 -- you should also unload the current program (set targets to empty,
2261 -- followed by load).
2262 workingDirectoryChanged :: GhcMonad m => m ()
2263 workingDirectoryChanged = withSession $ (liftIO . flushFinderCaches)
2264
2265 -- -----------------------------------------------------------------------------
2266 -- inspecting the session
2267
2268 -- | Get the module dependency graph.
2269 getModuleGraph :: GhcMonad m => m ModuleGraph -- ToDo: DiGraph ModSummary
2270 getModuleGraph = liftM hsc_mod_graph getSession
2271
2272 -- | Determines whether a set of modules requires Template Haskell.
2273 --
2274 -- Note that if the session's 'DynFlags' enabled Template Haskell when
2275 -- 'depanal' was called, then each module in the returned module graph will
2276 -- have Template Haskell enabled whether it is actually needed or not.
2277 needsTemplateHaskell :: ModuleGraph -> Bool
2278 needsTemplateHaskell ms =
2279 any (xopt Opt_TemplateHaskell . ms_hspp_opts) ms
2280
2281 -- | Return @True@ <==> module is loaded.
2282 isLoaded :: GhcMonad m => ModuleName -> m Bool
2283 isLoaded m = withSession $ \hsc_env ->
2284 return $! isJust (lookupUFM (hsc_HPT hsc_env) m)
2285
2286 -- | Return the bindings for the current interactive session.
2287 getBindings :: GhcMonad m => m [TyThing]
2288 getBindings = withSession $ \hsc_env ->
2289 -- we have to implement the shadowing behaviour of ic_tmp_ids here
2290 -- (see InteractiveContext) and the quickest way is to use an OccEnv.
2291 let
2292 occ_env = mkOccEnv [ (nameOccName (idName id), AnId id)
2293 | id <- ic_tmp_ids (hsc_IC hsc_env) ]
2294 in
2295 return (occEnvElts occ_env)
2296
2297 getPrintUnqual :: GhcMonad m => m PrintUnqualified
2298 getPrintUnqual = withSession $ \hsc_env ->
2299 return (icPrintUnqual (hsc_dflags hsc_env) (hsc_IC hsc_env))
2300
2301 -- | Container for information about a 'Module'.
2302 data ModuleInfo = ModuleInfo {
2303 minf_type_env :: TypeEnv,
2304 minf_exports :: NameSet, -- ToDo, [AvailInfo] like ModDetails?
2305 minf_rdr_env :: Maybe GlobalRdrEnv, -- Nothing for a compiled/package mod
2306 minf_instances :: [Instance]
2307 #ifdef GHCI
2308 ,minf_modBreaks :: ModBreaks
2309 #endif
2310 -- ToDo: this should really contain the ModIface too
2311 }
2312 -- We don't want HomeModInfo here, because a ModuleInfo applies
2313 -- to package modules too.
2314
2315 -- | Request information about a loaded 'Module'
2316 getModuleInfo :: GhcMonad m => Module -> m (Maybe ModuleInfo) -- XXX: Maybe X
2317 getModuleInfo mdl = withSession $ \hsc_env -> do
2318 let mg = hsc_mod_graph hsc_env
2319 if mdl `elem` map ms_mod mg
2320 then liftIO $ getHomeModuleInfo hsc_env (moduleName mdl)
2321 else do
2322 {- if isHomeModule (hsc_dflags hsc_env) mdl
2323 then return Nothing
2324 else -} liftIO $ getPackageModuleInfo hsc_env mdl
2325 -- getPackageModuleInfo will attempt to find the interface, so
2326 -- we don't want to call it for a home module, just in case there
2327 -- was a problem loading the module and the interface doesn't
2328 -- exist... hence the isHomeModule test here. (ToDo: reinstate)
2329
2330 getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
2331 #ifdef GHCI
2332 getPackageModuleInfo hsc_env mdl = do
2333 mb_avails <- hscGetModuleExports hsc_env mdl
2334 case mb_avails of
2335 Nothing -> return Nothing
2336 Just avails -> do
2337 eps <- readIORef (hsc_EPS hsc_env)
2338 let
2339 names = availsToNameSet avails
2340 pte = eps_PTE eps
2341 tys = [ ty | name <- concatMap availNames avails,
2342 Just ty <- [lookupTypeEnv pte name] ]
2343 --
2344 return (Just (ModuleInfo {
2345 minf_type_env = mkTypeEnv tys,
2346 minf_exports = names,
2347 minf_rdr_env = Just $! availsToGlobalRdrEnv (moduleName mdl) avails,
2348 minf_instances = error "getModuleInfo: instances for package module unimplemented",
2349 minf_modBreaks = emptyModBreaks
2350 }))
2351 #else
2352 getPackageModuleInfo _hsc_env _mdl = do
2353 -- bogusly different for non-GHCI (ToDo)
2354 return Nothing
2355 #endif
2356
2357 getHomeModuleInfo :: HscEnv -> ModuleName -> IO (Maybe ModuleInfo)
2358 getHomeModuleInfo hsc_env mdl =
2359 case lookupUFM (hsc_HPT hsc_env) mdl of
2360 Nothing -> return Nothing
2361 Just hmi -> do
2362 let details = hm_details hmi
2363 return (Just (ModuleInfo {
2364 minf_type_env = md_types details,
2365 minf_exports = availsToNameSet (md_exports details),
2366 minf_rdr_env = mi_globals $! hm_iface hmi,
2367 minf_instances = md_insts details
2368 #ifdef GHCI
2369 ,minf_modBreaks = getModBreaks hmi
2370 #endif
2371 }))
2372
2373 -- | The list of top-level entities defined in a module
2374 modInfoTyThings :: ModuleInfo -> [TyThing]
2375 modInfoTyThings minf = typeEnvElts (minf_type_env minf)
2376
2377 modInfoTopLevelScope :: ModuleInfo -> Maybe [Name]
2378 modInfoTopLevelScope minf
2379 = fmap (map gre_name . globalRdrEnvElts) (minf_rdr_env minf)
2380
2381 modInfoExports :: ModuleInfo -> [Name]
2382 modInfoExports minf = nameSetToList $! minf_exports minf
2383
2384 -- | Returns the instances defined by the specified module.
2385 -- Warning: currently unimplemented for package modules.
2386 modInfoInstances :: ModuleInfo -> [Instance]
2387 modInfoInstances = minf_instances
2388
2389 modInfoIsExportedName :: ModuleInfo -> Name -> Bool
2390 modInfoIsExportedName minf name = elemNameSet name (minf_exports minf)
2391
2392 mkPrintUnqualifiedForModule :: GhcMonad m =>
2393 ModuleInfo
2394 -> m (Maybe PrintUnqualified) -- XXX: returns a Maybe X
2395 mkPrintUnqualifiedForModule minf = withSession $ \hsc_env -> do
2396 return (fmap (mkPrintUnqualified (hsc_dflags hsc_env)) (minf_rdr_env minf))
2397
2398 modInfoLookupName :: GhcMonad m =>
2399 ModuleInfo -> Name
2400 -> m (Maybe TyThing) -- XXX: returns a Maybe X
2401 modInfoLookupName minf name = withSession $ \hsc_env -> do
2402 case lookupTypeEnv (minf_type_env minf) name of
2403 Just tyThing -> return (Just tyThing)
2404 Nothing -> do
2405 eps <- liftIO $ readIORef (hsc_EPS hsc_env)
2406 return $! lookupType (hsc_dflags hsc_env)
2407 (hsc_HPT hsc_env) (eps_PTE eps) name
2408
2409 #ifdef GHCI
2410 modInfoModBreaks :: ModuleInfo -> ModBreaks
2411 modInfoModBreaks = minf_modBreaks
2412 #endif
2413
2414 isDictonaryId :: Id -> Bool
2415 isDictonaryId id
2416 = case tcSplitSigmaTy (idType id) of { (_tvs, _theta, tau) -> isDictTy tau }
2417
2418 -- | Looks up a global name: that is, any top-level name in any
2419 -- visible module. Unlike 'lookupName', lookupGlobalName does not use
2420 -- the interactive context, and therefore does not require a preceding
2421 -- 'setContext'.
2422 lookupGlobalName :: GhcMonad m => Name -> m (Maybe TyThing)
2423 lookupGlobalName name = withSession $ \hsc_env -> do
2424 liftIO $ lookupTypeHscEnv hsc_env name
2425
2426 findGlobalAnns :: (GhcMonad m, Typeable a) => ([Word8] -> a) -> AnnTarget Name -> m [a]
2427 findGlobalAnns deserialize target = withSession $ \hsc_env -> do
2428 ann_env <- liftIO $ prepareAnnotations hsc_env Nothing
2429 return (findAnns deserialize ann_env target)
2430
2431 #ifdef GHCI
2432 -- | get the GlobalRdrEnv for a session
2433 getGRE :: GhcMonad m => m GlobalRdrEnv
2434 getGRE = withSession $ \hsc_env-> return $ ic_rn_gbl_env (hsc_IC hsc_env)
2435 #endif
2436
2437 -- -----------------------------------------------------------------------------
2438
2439 -- | Return all /external/ modules available in the package database.
2440 -- Modules from the current session (i.e., from the 'HomePackageTable') are
2441 -- not included.
2442 packageDbModules :: GhcMonad m =>
2443 Bool -- ^ Only consider exposed packages.
2444 -> m [Module]
2445 packageDbModules only_exposed = do
2446 dflags <- getSessionDynFlags
2447 let pkgs = eltsUFM (pkgIdMap (pkgState dflags))
2448 return $
2449 [ mkModule pid modname | p <- pkgs
2450 , not only_exposed || exposed p
2451 , let pid = packageConfigId p
2452 , modname <- exposedModules p ]
2453
2454 -- -----------------------------------------------------------------------------
2455 -- Misc exported utils
2456
2457 dataConType :: DataCon -> Type
2458 dataConType dc = idType (dataConWrapId dc)
2459
2460 -- | print a 'NamedThing', adding parentheses if the name is an operator.
2461 pprParenSymName :: NamedThing a => a -> SDoc
2462 pprParenSymName a = parenSymOcc (getOccName a) (ppr (getName a))
2463
2464 -- ----------------------------------------------------------------------------
2465
2466 #if 0
2467
2468 -- ToDo:
2469 -- - Data and Typeable instances for HsSyn.
2470
2471 -- ToDo: check for small transformations that happen to the syntax in
2472 -- the typechecker (eg. -e ==> negate e, perhaps for fromIntegral)
2473
2474 -- ToDo: maybe use TH syntax instead of IfaceSyn? There's already a way
2475 -- to get from TyCons, Ids etc. to TH syntax (reify).
2476
2477 -- :browse will use either lm_toplev or inspect lm_interface, depending
2478 -- on whether the module is interpreted or not.
2479
2480 #endif
2481
2482 -- Extract the filename, stringbuffer content and dynflags associed to a module
2483 --
2484 -- XXX: Explain pre-conditions
2485 getModuleSourceAndFlags :: GhcMonad m => Module -> m (String, StringBuffer, DynFlags)
2486 getModuleSourceAndFlags mod = do
2487 m <- getModSummary (moduleName mod)
2488 case ml_hs_file $ ms_location m of
2489 Nothing -> throw $ mkApiErr (text "No source available for module " <+> ppr mod)
2490 Just sourceFile -> do
2491 source <- liftIO $ hGetStringBuffer sourceFile
2492 return (sourceFile, source, ms_hspp_opts m)
2493
2494
2495 -- | Return module source as token stream, including comments.
2496 --
2497 -- The module must be in the module graph and its source must be available.
2498 -- Throws a 'HscTypes.SourceError' on parse error.
2499 getTokenStream :: GhcMonad m => Module -> m [Located Token]
2500 getTokenStream mod = do
2501 (sourceFile, source, flags) <- getModuleSourceAndFlags mod
2502 let startLoc = mkSrcLoc (mkFastString sourceFile) 1 1
2503 case lexTokenStream source startLoc flags of
2504 POk _ ts -> return ts
2505 PFailed span err -> throw $ mkSrcErr (unitBag $ mkPlainErrMsg span err)
2506
2507 -- | Give even more information on the source than 'getTokenStream'
2508 -- This function allows reconstructing the source completely with
2509 -- 'showRichTokenStream'.
2510 getRichTokenStream :: GhcMonad m => Module -> m [(Located Token, String)]
2511 getRichTokenStream mod = do
2512 (sourceFile, source, flags) <- getModuleSourceAndFlags mod
2513 let startLoc = mkSrcLoc (mkFastString sourceFile) 1 1
2514 case lexTokenStream source startLoc flags of
2515 POk _ ts -> return $ addSourceToTokens startLoc source ts
2516 PFailed span err -> throw $ mkSrcErr (unitBag $ mkPlainErrMsg span err)
2517
2518 -- | Given a source location and a StringBuffer corresponding to this
2519 -- location, return a rich token stream with the source associated to the
2520 -- tokens.
2521 addSourceToTokens :: SrcLoc -> StringBuffer -> [Located Token]
2522 -> [(Located Token, String)]
2523 addSourceToTokens _ _ [] = []
2524 addSourceToTokens loc buf (t@(L span _) : ts)
2525 | not (isGoodSrcSpan span) = (t,"") : addSourceToTokens loc buf ts
2526 | otherwise = (t,str) : addSourceToTokens newLoc newBuf ts
2527 where
2528 (newLoc, newBuf, str) = go "" loc buf
2529 start = srcSpanStart span
2530 end = srcSpanEnd span
2531 go acc loc buf | loc < start = go acc nLoc nBuf
2532 | start <= loc && loc < end = go (ch:acc) nLoc nBuf
2533 | otherwise = (loc, buf, reverse acc)
2534 where (ch, nBuf) = nextChar buf
2535 nLoc = advanceSrcLoc loc ch
2536
2537
2538 -- | Take a rich token stream such as produced from 'getRichTokenStream' and
2539 -- return source code almost identical to the original code (except for
2540 -- insignificant whitespace.)
2541 showRichTokenStream :: [(Located Token, String)] -> String
2542 showRichTokenStream ts = go startLoc ts ""
2543 where sourceFile = srcSpanFile (getLoc . fst . head $ ts)
2544 startLoc = mkSrcLoc sourceFile 1 1
2545 go _ [] = id
2546 go loc ((L span _, str):ts)
2547 | not (isGoodSrcSpan span) = go loc ts
2548 | locLine == tokLine = ((replicate (tokCol - locCol) ' ') ++)
2549 . (str ++)
2550 . go tokEnd ts
2551 | otherwise = ((replicate (tokLine - locLine) '\n') ++)
2552 . ((replicate tokCol ' ') ++)
2553 . (str ++)
2554 . go tokEnd ts
2555 where (locLine, locCol) = (srcLocLine loc, srcLocCol loc)
2556 (tokLine, tokCol) = (srcSpanStartLine span, srcSpanStartCol span)
2557 tokEnd = srcSpanEnd span
2558
2559 -- -----------------------------------------------------------------------------
2560 -- Interactive evaluation
2561
2562 -- | Takes a 'ModuleName' and possibly a 'PackageId', and consults the
2563 -- filesystem and package database to find the corresponding 'Module',
2564 -- using the algorithm that is used for an @import@ declaration.
2565 findModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module
2566 findModule mod_name maybe_pkg = withSession $ \hsc_env -> do
2567 let
2568 dflags = hsc_dflags hsc_env
2569 this_pkg = thisPackage dflags
2570 --
2571 case maybe_pkg of
2572 Just pkg | fsToPackageId pkg /= this_pkg && pkg /= fsLit "this" -> liftIO $ do
2573 res <- findImportedModule hsc_env mod_name maybe_pkg
2574 case res of
2575 Found _ m -> return m
2576 err -> noModError dflags noSrcSpan mod_name err
2577 _otherwise -> do
2578 home <- lookupLoadedHomeModule mod_name
2579 case home of
2580 Just m -> return m
2581 Nothing -> liftIO $ do
2582 res <- findImportedModule hsc_env mod_name maybe_pkg
2583 case res of
2584 Found loc m | modulePackageId m /= this_pkg -> return m
2585 | otherwise -> modNotLoadedError m loc
2586 err -> noModError dflags noSrcSpan mod_name err
2587
2588 modNotLoadedError :: Module -> ModLocation -> IO a
2589 modNotLoadedError m loc = ghcError $ CmdLineError $ showSDoc $
2590 text "module is not loaded:" <+>
2591 quotes (ppr (moduleName m)) <+>
2592 parens (text (expectJust "modNotLoadedError" (ml_hs_file loc)))
2593
2594 -- | Like 'findModule', but differs slightly when the module refers to
2595 -- a source file, and the file has not been loaded via 'load'. In
2596 -- this case, 'findModule' will throw an error (module not loaded),
2597 -- but 'lookupModule' will check to see whether the module can also be
2598 -- found in a package, and if so, that package 'Module' will be
2599 -- returned. If not, the usual module-not-found error will be thrown.
2600 --
2601 lookupModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module
2602 lookupModule mod_name (Just pkg) = findModule mod_name (Just pkg)
2603 lookupModule mod_name Nothing = withSession $ \hsc_env -> do
2604 home <- lookupLoadedHomeModule mod_name
2605 case home of
2606 Just m -> return m
2607 Nothing -> liftIO $ do
2608 res <- findExposedPackageModule hsc_env mod_name Nothing
2609 case res of
2610 Found _ m -> return m
2611 err -> noModError (hsc_dflags hsc_env) noSrcSpan mod_name err
2612
2613 lookupLoadedHomeModule :: GhcMonad m => ModuleName -> m (Maybe Module)
2614 lookupLoadedHomeModule mod_name = withSession $ \hsc_env ->
2615 case lookupUFM (hsc_HPT hsc_env) mod_name of
2616 Just mod_info -> return (Just (mi_module (hm_iface mod_info)))
2617 _not_a_home_module -> return Nothing
2618
2619 #ifdef GHCI
2620 getHistorySpan :: GhcMonad m => History -> m SrcSpan
2621 getHistorySpan h = withSession $ \hsc_env ->
2622 return$ InteractiveEval.getHistorySpan hsc_env h
2623
2624 obtainTermFromVal :: GhcMonad m => Int -> Bool -> Type -> a -> m Term
2625 obtainTermFromVal bound force ty a =
2626 withSession $ \hsc_env ->
2627 liftIO $ InteractiveEval.obtainTermFromVal hsc_env bound force ty a
2628
2629 obtainTermFromId :: GhcMonad m => Int -> Bool -> Id -> m Term
2630 obtainTermFromId bound force id =
2631 withSession $ \hsc_env ->
2632 liftIO $ InteractiveEval.obtainTermFromId hsc_env bound force id
2633
2634 #endif
2635
2636 -- | Returns the 'TyThing' for a 'Name'. The 'Name' may refer to any
2637 -- entity known to GHC, including 'Name's defined using 'runStmt'.
2638 lookupName :: GhcMonad m => Name -> m (Maybe TyThing)
2639 lookupName name =
2640 withSession $ \hsc_env ->
2641 liftIO $ hscTcRcLookupName hsc_env name
2642
2643 -- -----------------------------------------------------------------------------
2644 -- Pure API
2645
2646 -- | A pure interface to the module parser.
2647 --
2648 parser :: String -- ^ Haskell module source text (full Unicode is supported)
2649 -> DynFlags -- ^ the flags
2650 -> FilePath -- ^ the filename (for source locations)
2651 -> Either ErrorMessages (WarningMessages, Located (HsModule RdrName))
2652
2653 parser str dflags filename =
2654 let
2655 loc = mkSrcLoc (mkFastString filename) 1 1
2656 buf = stringToStringBuffer str
2657 in
2658 case unP Parser.parseModule (mkPState dflags buf loc) of
2659
2660 PFailed span err ->
2661 Left (unitBag (mkPlainErrMsg span err))
2662
2663 POk pst rdr_module ->
2664 let (warns,_) = getMessages pst in
2665 Right (warns, rdr_module)