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