1 -- -----------------------------------------------------------------------------
3 -- (c) The University of Glasgow, 2005
7 -- -----------------------------------------------------------------------------
12 defaultCleanupHandler,
15 Ghc, GhcT, GhcMonad(..),
16 runGhc, runGhcT, initGhcMonad,
17 gcatch, gbracket, gfinally,
18 clearWarnings, getWarnings, hasWarnings,
19 printExceptionAndWarnings, printWarnings,
20 handleSourceError, defaultCallbacks, GhcApiCallbacks(..),
23 -- * Flags and settings
24 DynFlags(..), DynFlag(..), Severity(..), HscTarget(..), dopt,
25 GhcMode(..), GhcLink(..), defaultObjectTarget,
32 Target(..), TargetId(..), Phase,
39 -- * Extending the program scope
42 extendGlobalTypeScope,
45 -- * Loading\/compiling the program
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,
61 -- * Parsing Haddock comments
64 -- * Inspecting the module structure of the program
65 ModuleGraph, ModSummary(..), ms_mod_name, ModLocation(..),
70 -- * Inspecting modules
77 modInfoIsExportedName,
81 mkPrintUnqualifiedForModule,
83 -- * Querying the environment
87 PrintUnqualified, alwaysQualify,
89 -- * Interactive evaluation
90 getBindings, getPrintUnqual,
94 setContext, getContext,
104 runStmt, SingleStep(..),
106 Resume(resumeStmt, resumeThreadId, resumeBreakInfo, resumeSpan,
107 resumeHistory, resumeHistoryIx),
108 History(historyBreakInfo, historyEnclosingDecl),
109 GHC.getHistorySpan, getHistoryModule,
112 InteractiveEval.back,
113 InteractiveEval.forward,
116 InteractiveEval.compileExpr, HValue, dynCompileExpr,
118 GHC.obtainTermFromId, GHC.obtainTermFromVal, reconstructType,
120 ModBreaks(..), BreakIndex,
121 BreakInfo(breakInfo_number, breakInfo_module),
122 BreakArray, setBreakOn, setBreakOff, getBreak,
125 -- * Abstract syntax elements
131 Module, mkModule, pprModule, moduleName, modulePackageId,
132 ModuleName, mkModuleName, moduleNameString,
136 isExternalName, nameModule, pprParenSymName, nameSrcSpan,
138 RdrName(Qual,Unqual),
142 isImplicitId, isDeadBinder,
143 isExportedId, isLocalId, isGlobalId,
145 isPrimOpId, isFCallId, isClassOpId_maybe,
146 isDataConWorkId, idDataCon,
147 isBottomingId, isDictonaryId,
148 recordSelectorFieldLabel,
150 -- ** Type constructors
152 tyConTyVars, tyConDataCons, tyConArity,
153 isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon,
155 synTyConDefn, synTyConType, synTyConResKind,
161 -- ** Data constructors
163 dataConSig, dataConType, dataConTyCon, dataConFieldLabels,
164 dataConIsInfix, isVanillaDataCon,
166 StrictnessMark(..), isMarkedStrict,
170 classMethods, classSCTheta, classTvsFds,
175 instanceDFunId, pprInstance, pprInstanceHdr,
177 -- ** Types and Kinds
178 Type, splitForAllTys, funResultTy,
179 pprParendType, pprTypeApp,
182 ThetaType, pprThetaArrow,
188 module HsSyn, -- ToDo: remove extraneous bits
192 defaultFixity, maxPrecedence,
196 -- ** Source locations
198 mkSrcLoc, isGoodSrcLoc, noSrcLoc,
199 srcLocFile, srcLocLine, srcLocCol,
201 mkSrcSpan, srcLocSpan, isGoodSrcSpan, noSrcSpan,
202 srcSpanStart, srcSpanEnd,
204 srcSpanStartLine, srcSpanEndLine,
205 srcSpanStartCol, srcSpanEndCol,
210 -- *** Constructing Located
211 noLoc, mkGeneralLocated,
213 -- *** Deconstructing Located
216 -- *** Combining and comparing Located values
217 eqLocated, cmpLocated, combineLocs, addCLoc,
218 leftmost_smallest, leftmost_largest, rightmost,
222 GhcException(..), showGhcException,
224 -- * Token stream manipulations
226 getTokenStream, getRichTokenStream,
227 showRichTokenStream, addSourceToTokens,
237 * inline bits of HscMain here to simplify layering: hscTcExpr, hscStmt.
238 * what StaticFlags should we expose, if any?
241 #include "HsVersions.h"
244 import qualified Linker
245 import Linker ( HValue )
249 import InteractiveEval
254 import TcRnTypes hiding (LIE)
255 import TcRnMonad ( initIfaceCheck )
259 import qualified HsSyn -- hack as we want to reexport the whole module
260 import HsSyn hiding ((<.>))
261 import Type hiding (typeKind)
262 import TcType hiding (typeKind)
265 import TysPrim ( alphaTyVars )
270 import Name hiding ( varName )
271 import OccName ( parenSymOcc )
272 import InstEnv ( Instance, instanceDFunId, pprInstance, pprInstanceHdr,
274 import FamInstEnv ( emptyFamInstEnv )
278 import DriverPipeline
279 import DriverPhases ( HscSource(..), Phase(..), isHaskellSrcFilename, startPhase )
285 import StaticFlagParser
286 import qualified StaticFlags
287 import SysTools ( initSysTools, cleanTempFiles, cleanTempFilesExcept,
292 import qualified UniqFM as UFM
296 import Bag ( unitBag, listToBag, emptyBag, isEmptyBag )
300 import StringBuffer ( StringBuffer, hGetStringBuffer, nextChar )
303 import Maybes ( expectJust, mapCatMaybes )
305 import HaddockLex ( tokenise )
309 import Control.Concurrent
310 import System.Directory ( getModificationTime, doesFileExist,
311 getCurrentDirectory )
314 import qualified Data.List as List
315 import Data.Typeable ( Typeable )
316 import Data.Word ( Word8 )
318 import System.Exit ( exitWith, ExitCode(..) )
319 import System.Time ( ClockTime, getClockTime )
322 import System.FilePath
324 import System.IO.Error ( try, isDoesNotExistError )
325 import Prelude hiding (init)
328 -- -----------------------------------------------------------------------------
329 -- Exception handlers
331 -- | Install some default exception handlers and run the inner computation.
332 -- Unless you want to handle exceptions yourself, you should wrap this around
333 -- the top level of your program. The default handlers output the error
334 -- message(s) to stderr and exit cleanly.
335 defaultErrorHandler :: (ExceptionMonad m, MonadIO m) => DynFlags -> m a -> m a
336 defaultErrorHandler dflags inner =
337 -- top-level exception handler: any unrecognised exception is a compiler bug.
338 ghandle (\exception -> liftIO $ do
340 case fromException exception of
341 -- an IO exception probably isn't our fault, so don't panic
342 Just (ioe :: IOException) ->
343 fatalErrorMsg dflags (text (show ioe))
344 _ -> case fromException exception of
345 Just StackOverflow ->
346 fatalErrorMsg dflags (text "stack overflow: use +RTS -K<size> to increase it")
347 _ -> case fromException exception of
348 Just (ex :: ExitCode) -> throw ex
351 (text (show (Panic (show exception))))
352 exitWith (ExitFailure 1)
355 -- error messages propagated as exceptions
360 PhaseFailed _ code -> exitWith code
361 Interrupted -> exitWith (ExitFailure 1)
362 _ -> do fatalErrorMsg dflags (text (show ge))
363 exitWith (ExitFailure 1)
367 -- | Install a default cleanup handler to remove temporary files deposited by
368 -- a GHC run. This is seperate from 'defaultErrorHandler', because you might
369 -- want to override the error handling, but still get the ordinary cleanup
371 defaultCleanupHandler :: (ExceptionMonad m, MonadIO m) =>
372 DynFlags -> m a -> m a
373 defaultCleanupHandler dflags inner =
374 -- make sure we clean up after ourselves
377 cleanTempFiles dflags
380 -- exceptions will be blocked while we clean the temporary files,
381 -- so there shouldn't be any difficulty if we receive further
384 -- | Print the error message and all warnings. Useful inside exception
385 -- handlers. Clears warnings after printing.
386 printExceptionAndWarnings :: GhcMonad m => SourceError -> m ()
387 printExceptionAndWarnings err = do
388 let errs = srcErrorMessages err
390 dflags <- getSessionDynFlags
392 -- Empty errors means we failed due to -Werror. (Since this function
393 -- takes a source error as argument, we know for sure _some_ error
394 -- did indeed happen.)
396 printBagOfWarnings dflags warns
397 printBagOfErrors dflags (unitBag warnIsErrorMsg)
398 else liftIO $ printBagOfErrors dflags errs
401 -- | Print all accumulated warnings using 'log_action'.
402 printWarnings :: GhcMonad m => m ()
404 dflags <- getSessionDynFlags
406 liftIO $ printBagOfWarnings dflags warns
409 -- | Run function for the 'Ghc' monad.
411 -- It initialises the GHC session and warnings via 'initGhcMonad'. Each call
412 -- to this function will create a new session which should not be shared among
415 -- Any errors not handled inside the 'Ghc' action are propagated as IO
418 runGhc :: Maybe FilePath -- ^ See argument to 'initGhcMonad'.
419 -> Ghc a -- ^ The action to perform.
421 runGhc mb_top_dir ghc = do
422 wref <- newIORef emptyBag
423 ref <- newIORef undefined
424 let session = Session ref wref
425 flip unGhc session $ do
426 initGhcMonad mb_top_dir
428 -- XXX: unregister interrupt handlers here?
430 -- | Run function for 'GhcT' monad transformer.
432 -- It initialises the GHC session and warnings via 'initGhcMonad'. Each call
433 -- to this function will create a new session which should not be shared among
436 runGhcT :: (ExceptionMonad m, Functor m, MonadIO m) =>
437 Maybe FilePath -- ^ See argument to 'initGhcMonad'.
438 -> GhcT m a -- ^ The action to perform.
440 runGhcT mb_top_dir ghct = do
441 wref <- liftIO $ newIORef emptyBag
442 ref <- liftIO $ newIORef undefined
443 let session = Session ref wref
444 flip unGhcT session $ do
445 initGhcMonad mb_top_dir
448 -- | Initialise a GHC session.
450 -- If you implement a custom 'GhcMonad' you must call this function in the
451 -- monad run function. It will initialise the session variable and clear all
454 -- The first argument should point to the directory where GHC's library files
455 -- reside. More precisely, this should be the output of @ghc --print-libdir@
456 -- of the version of GHC the module using this API is compiled with. For
457 -- portability, you should use the @ghc-paths@ package, available at
458 -- <http://hackage.haskell.org/cgi-bin/hackage-scripts/package/ghc-paths>.
460 initGhcMonad :: GhcMonad m => Maybe FilePath -> m ()
461 initGhcMonad mb_top_dir = do
463 main_thread <- liftIO $ myThreadId
464 liftIO $ modifyMVar_ interruptTargetThread (return . (main_thread :))
465 liftIO $ installSignalHandlers
467 liftIO $ StaticFlags.initStaticOpts
469 dflags0 <- liftIO $ initDynFlags defaultDynFlags
470 dflags <- liftIO $ initSysTools mb_top_dir dflags0
471 env <- liftIO $ newHscEnv defaultCallbacks dflags
475 defaultCallbacks :: GhcApiCallbacks
478 reportModuleCompilationResult =
479 \_ mb_err -> defaultWarnErrLogger mb_err
482 -- -----------------------------------------------------------------------------
485 -- | Grabs the DynFlags from the Session
486 getSessionDynFlags :: GhcMonad m => m DynFlags
487 getSessionDynFlags = withSession (return . hsc_dflags)
489 -- | Updates the DynFlags in a Session. This also reads
490 -- the package database (unless it has already been read),
491 -- and prepares the compilers knowledge about packages. It
492 -- can be called again to load new packages: just add new
493 -- package flags to (packageFlags dflags).
495 -- Returns a list of new packages that may need to be linked in using
496 -- the dynamic linker (see 'linkPackages') as a result of new package
497 -- flags. If you are not doing linking or doing static linking, you
498 -- can ignore the list of packages returned.
500 setSessionDynFlags :: GhcMonad m => DynFlags -> m [PackageId]
501 setSessionDynFlags dflags = do
502 (dflags', preload) <- liftIO $ initPackages dflags
503 modifySession (\h -> h{ hsc_dflags = dflags' })
506 -- | If there is no -o option, guess the name of target executable
507 -- by using top-level source file name as a base.
508 guessOutputFile :: GhcMonad m => m ()
509 guessOutputFile = modifySession $ \env ->
510 let dflags = hsc_dflags env
511 mod_graph = hsc_mod_graph env
512 mainModuleSrcPath :: Maybe String
513 mainModuleSrcPath = do
514 let isMain = (== mainModIs dflags) . ms_mod
515 [ms] <- return (filter isMain mod_graph)
516 ml_hs_file (ms_location ms)
517 name = fmap dropExtension mainModuleSrcPath
519 #if defined(mingw32_HOST_OS)
520 -- we must add the .exe extention unconditionally here, otherwise
521 -- when name has an extension of its own, the .exe extension will
522 -- not be added by DriverPipeline.exeFileName. See #2248
523 name_exe = fmap (<.> "exe") name
528 case outputFile dflags of
530 Nothing -> env { hsc_dflags = dflags { outputFile = name_exe } }
532 -- -----------------------------------------------------------------------------
535 -- ToDo: think about relative vs. absolute file paths. And what
536 -- happens when the current directory changes.
538 -- | Sets the targets for this session. Each target may be a module name
539 -- or a filename. The targets correspond to the set of root modules for
540 -- the program\/library. Unloading the current program is achieved by
541 -- setting the current set of targets to be empty, followed by 'load'.
542 setTargets :: GhcMonad m => [Target] -> m ()
543 setTargets targets = modifySession (\h -> h{ hsc_targets = targets })
545 -- | Returns the current set of targets
546 getTargets :: GhcMonad m => m [Target]
547 getTargets = withSession (return . hsc_targets)
549 -- | Add another target.
550 addTarget :: GhcMonad m => Target -> m ()
552 = modifySession (\h -> h{ hsc_targets = target : hsc_targets h })
555 removeTarget :: GhcMonad m => TargetId -> m ()
556 removeTarget target_id
557 = modifySession (\h -> h{ hsc_targets = filter (hsc_targets h) })
559 filter targets = [ t | t@(Target id _ _) <- targets, id /= target_id ]
561 -- | Attempts to guess what Target a string refers to. This function
562 -- implements the @--make@/GHCi command-line syntax for filenames:
564 -- - if the string looks like a Haskell source filename, then interpret it
567 -- - if adding a .hs or .lhs suffix yields the name of an existing file,
570 -- - otherwise interpret the string as a module name
572 guessTarget :: GhcMonad m => String -> Maybe Phase -> m Target
573 guessTarget str (Just phase)
574 = return (Target (TargetFile str (Just phase)) True Nothing)
575 guessTarget str Nothing
576 | isHaskellSrcFilename file
577 = return (target (TargetFile file Nothing))
579 = do exists <- liftIO $ doesFileExist hs_file
581 then return (target (TargetFile hs_file Nothing))
583 exists <- liftIO $ doesFileExist lhs_file
585 then return (target (TargetFile lhs_file Nothing))
587 if looksLikeModuleName file
588 then return (target (TargetModule (mkModuleName file)))
591 (ProgramError (showSDoc $
592 text "target" <+> quotes (text file) <+>
593 text "is not a module name or a source file"))
596 | '*':rest <- str = (rest, False)
597 | otherwise = (str, True)
599 hs_file = file <.> "hs"
600 lhs_file = file <.> "lhs"
602 target tid = Target tid obj_allowed Nothing
604 -- -----------------------------------------------------------------------------
605 -- Extending the program scope
607 extendGlobalRdrScope :: GhcMonad m => [GlobalRdrElt] -> m ()
608 extendGlobalRdrScope rdrElts
609 = modifySession $ \hscEnv ->
610 let global_rdr = hsc_global_rdr_env hscEnv
611 in hscEnv{ hsc_global_rdr_env = foldl extendGlobalRdrEnv global_rdr rdrElts }
613 setGlobalRdrScope :: GhcMonad m => [GlobalRdrElt] -> m ()
614 setGlobalRdrScope rdrElts
615 = modifySession $ \hscEnv ->
616 hscEnv{ hsc_global_rdr_env = foldl extendGlobalRdrEnv emptyGlobalRdrEnv rdrElts }
618 extendGlobalTypeScope :: GhcMonad m => [Id] -> m ()
619 extendGlobalTypeScope ids
620 = modifySession $ \hscEnv ->
621 let global_type = hsc_global_type_env hscEnv
622 in hscEnv{ hsc_global_type_env = extendTypeEnvWithIds global_type ids }
624 setGlobalTypeScope :: GhcMonad m => [Id] -> m ()
625 setGlobalTypeScope ids
626 = modifySession $ \hscEnv ->
627 hscEnv{ hsc_global_type_env = extendTypeEnvWithIds emptyTypeEnv ids }
629 -- -----------------------------------------------------------------------------
630 -- Parsing Haddock comments
632 parseHaddockComment :: String -> Either String (HsDoc RdrName)
633 parseHaddockComment string =
634 case parseHaddockParagraphs (tokenise string) of
638 -- -----------------------------------------------------------------------------
639 -- Loading the program
641 -- | Perform a dependency analysis starting from the current targets
642 -- and update the session with the new module graph.
644 -- Dependency analysis entails parsing the @import@ directives and may
645 -- therefore require running certain preprocessors.
647 -- Note that each 'ModSummary' in the module graph caches its 'DynFlags'.
648 -- These 'DynFlags' are determined by the /current/ session 'DynFlags' and the
649 -- @OPTIONS@ and @LANGUAGE@ pragmas of the parsed module. Thus if you want to
650 -- changes to the 'DynFlags' to take effect you need to call this function
653 depanal :: GhcMonad m =>
654 [ModuleName] -- ^ excluded modules
655 -> Bool -- ^ allow duplicate roots
657 depanal excluded_mods allow_dup_roots = do
658 hsc_env <- getSession
660 dflags = hsc_dflags hsc_env
661 targets = hsc_targets hsc_env
662 old_graph = hsc_mod_graph hsc_env
664 liftIO $ showPass dflags "Chasing dependencies"
665 liftIO $ debugTraceMsg dflags 2 (hcat [
666 text "Chasing modules from: ",
667 hcat (punctuate comma (map pprTarget targets))])
669 mod_graph <- downsweep hsc_env old_graph excluded_mods allow_dup_roots
670 modifySession $ \_ -> hsc_env { hsc_mod_graph = mod_graph }
673 -- | Describes which modules of the module graph need to be loaded.
676 -- ^ Load all targets and its dependencies.
677 | LoadUpTo ModuleName
678 -- ^ Load only the given module and its dependencies.
679 | LoadDependenciesOf ModuleName
680 -- ^ Load only the dependencies of the given module, but not the module
683 -- | Try to load the program. See 'LoadHowMuch' for the different modes.
685 -- This function implements the core of GHC's @--make@ mode. It preprocesses,
686 -- compiles and loads the specified modules, avoiding re-compilation wherever
687 -- possible. Depending on the target (see 'DynFlags.hscTarget') compilating
688 -- and loading may result in files being created on disk.
690 -- Calls the 'reportModuleCompilationResult' callback after each compiling
691 -- each module, whether successful or not.
693 -- Throw a 'SourceError' if errors are encountered before the actual
694 -- compilation starts (e.g., during dependency analysis). All other errors
695 -- are reported using the callback.
697 load :: GhcMonad m => LoadHowMuch -> m SuccessFlag
699 mod_graph <- depanal [] False
700 load2 how_much mod_graph
702 -- | A function called to log warnings and errors.
703 type WarnErrLogger = GhcMonad m => Maybe SourceError -> m ()
705 defaultWarnErrLogger :: WarnErrLogger
706 defaultWarnErrLogger Nothing = printWarnings
707 defaultWarnErrLogger (Just e) = printExceptionAndWarnings e
709 -- | Try to load the program. If a Module is supplied, then just
710 -- attempt to load up to this target. If no Module is supplied,
711 -- then try to load all targets.
713 -- The first argument is a function that is called after compiling each
714 -- module to print wanrings and errors.
716 -- While compiling a module, all 'SourceError's are caught and passed to the
717 -- logger, however, this function may still throw a 'SourceError' if
718 -- dependency analysis failed (e.g., due to a parse error).
720 loadWithLogger :: GhcMonad m => WarnErrLogger -> LoadHowMuch -> m SuccessFlag
721 loadWithLogger logger how_much = do
722 -- Dependency analysis first. Note that this fixes the module graph:
723 -- even if we don't get a fully successful upsweep, the full module
724 -- graph is still retained in the Session. We can tell which modules
725 -- were successfully loaded by inspecting the Session's HPT.
726 withLocalCallbacks (\cbs -> cbs { reportModuleCompilationResult =
730 load2 :: GhcMonad m => LoadHowMuch -> [ModSummary]
732 load2 how_much mod_graph = do
734 hsc_env <- getSession
736 let hpt1 = hsc_HPT hsc_env
737 let dflags = hsc_dflags hsc_env
739 -- The "bad" boot modules are the ones for which we have
740 -- B.hs-boot in the module graph, but no B.hs
741 -- The downsweep should have ensured this does not happen
743 let all_home_mods = [ms_mod_name s
744 | s <- mod_graph, not (isBootSummary s)]
745 bad_boot_mods = [s | s <- mod_graph, isBootSummary s,
746 not (ms_mod_name s `elem` all_home_mods)]
747 ASSERT( null bad_boot_mods ) return ()
749 -- check that the module given in HowMuch actually exists, otherwise
750 -- topSortModuleGraph will bomb later.
751 let checkHowMuch (LoadUpTo m) = checkMod m
752 checkHowMuch (LoadDependenciesOf m) = checkMod m
756 | m `elem` all_home_mods = and_then
758 liftIO $ errorMsg dflags (text "no such module:" <+>
762 checkHowMuch how_much $ do
764 -- mg2_with_srcimps drops the hi-boot nodes, returning a
765 -- graph with cycles. Among other things, it is used for
766 -- backing out partially complete cycles following a failed
767 -- upsweep, and for removing from hpt all the modules
768 -- not in strict downwards closure, during calls to compile.
769 let mg2_with_srcimps :: [SCC ModSummary]
770 mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing
772 -- If we can determine that any of the {-# SOURCE #-} imports
773 -- are definitely unnecessary, then emit a warning.
774 warnUnnecessarySourceImports mg2_with_srcimps
777 -- check the stability property for each module.
778 stable_mods@(stable_obj,stable_bco)
779 = checkStability hpt1 mg2_with_srcimps all_home_mods
781 -- prune bits of the HPT which are definitely redundant now,
783 pruned_hpt = pruneHomePackageTable hpt1
784 (flattenSCCs mg2_with_srcimps)
787 _ <- liftIO $ evaluate pruned_hpt
789 -- before we unload anything, make sure we don't leave an old
790 -- interactive context around pointing to dead bindings. Also,
791 -- write the pruned HPT to allow the old HPT to be GC'd.
792 modifySession $ \_ -> hsc_env{ hsc_IC = emptyInteractiveContext,
793 hsc_HPT = pruned_hpt }
795 liftIO $ debugTraceMsg dflags 2 (text "Stable obj:" <+> ppr stable_obj $$
796 text "Stable BCO:" <+> ppr stable_bco)
798 -- Unload any modules which are going to be re-linked this time around.
799 let stable_linkables = [ linkable
800 | m <- stable_obj++stable_bco,
801 Just hmi <- [lookupUFM pruned_hpt m],
802 Just linkable <- [hm_linkable hmi] ]
803 liftIO $ unload hsc_env stable_linkables
805 -- We could at this point detect cycles which aren't broken by
806 -- a source-import, and complain immediately, but it seems better
807 -- to let upsweep_mods do this, so at least some useful work gets
808 -- done before the upsweep is abandoned.
809 --hPutStrLn stderr "after tsort:\n"
810 --hPutStrLn stderr (showSDoc (vcat (map ppr mg2)))
812 -- Now do the upsweep, calling compile for each module in
813 -- turn. Final result is version 3 of everything.
815 -- Topologically sort the module graph, this time including hi-boot
816 -- nodes, and possibly just including the portion of the graph
817 -- reachable from the module specified in the 2nd argument to load.
818 -- This graph should be cycle-free.
819 -- If we're restricting the upsweep to a portion of the graph, we
820 -- also want to retain everything that is still stable.
821 let full_mg :: [SCC ModSummary]
822 full_mg = topSortModuleGraph False mod_graph Nothing
824 maybe_top_mod = case how_much of
826 LoadDependenciesOf m -> Just m
829 partial_mg0 :: [SCC ModSummary]
830 partial_mg0 = topSortModuleGraph False mod_graph maybe_top_mod
832 -- LoadDependenciesOf m: we want the upsweep to stop just
833 -- short of the specified module (unless the specified module
836 | LoadDependenciesOf _mod <- how_much
837 = ASSERT( case last partial_mg0 of
838 AcyclicSCC ms -> ms_mod_name ms == _mod; _ -> False )
839 List.init partial_mg0
845 | AcyclicSCC ms <- full_mg,
846 ms_mod_name ms `elem` stable_obj++stable_bco,
847 ms_mod_name ms `notElem` [ ms_mod_name ms' |
848 AcyclicSCC ms' <- partial_mg ] ]
850 mg = stable_mg ++ partial_mg
852 -- clean up between compilations
853 let cleanup = cleanTempFilesExcept dflags
854 (ppFilesFromSummaries (flattenSCCs mg2_with_srcimps))
856 liftIO $ debugTraceMsg dflags 2 (hang (text "Ready for upsweep")
858 (upsweep_ok, hsc_env1, modsUpswept)
859 <- upsweep (hsc_env { hsc_HPT = emptyHomePackageTable })
860 pruned_hpt stable_mods cleanup mg
862 -- Make modsDone be the summaries for each home module now
863 -- available; this should equal the domain of hpt3.
864 -- Get in in a roughly top .. bottom order (hence reverse).
866 let modsDone = reverse modsUpswept
868 -- Try and do linking in some form, depending on whether the
869 -- upsweep was completely or only partially successful.
871 if succeeded upsweep_ok
874 -- Easy; just relink it all.
875 do liftIO $ debugTraceMsg dflags 2 (text "Upsweep completely successful.")
877 -- Clean up after ourselves
878 liftIO $ cleanTempFilesExcept dflags (ppFilesFromSummaries modsDone)
880 -- Issue a warning for the confusing case where the user
881 -- said '-o foo' but we're not going to do any linking.
882 -- We attempt linking if either (a) one of the modules is
883 -- called Main, or (b) the user said -no-hs-main, indicating
884 -- that main() is going to come from somewhere else.
886 let ofile = outputFile dflags
887 let no_hs_main = dopt Opt_NoHsMain dflags
889 main_mod = mainModIs dflags
890 a_root_is_Main = any ((==main_mod).ms_mod) mod_graph
891 do_linking = a_root_is_Main || no_hs_main || ghcLink dflags == LinkDynLib
893 when (ghcLink dflags == LinkBinary
894 && isJust ofile && not do_linking) $
895 liftIO $ debugTraceMsg dflags 1 $
896 text ("Warning: output was redirected with -o, " ++
897 "but no output will be generated\n" ++
898 "because there is no " ++
899 moduleNameString (moduleName main_mod) ++ " module.")
901 -- link everything together
902 linkresult <- liftIO $ link (ghcLink dflags) dflags do_linking (hsc_HPT hsc_env1)
904 loadFinish Succeeded linkresult hsc_env1
907 -- Tricky. We need to back out the effects of compiling any
908 -- half-done cycles, both so as to clean up the top level envs
909 -- and to avoid telling the interactive linker to link them.
910 do liftIO $ debugTraceMsg dflags 2 (text "Upsweep partially successful.")
913 = map ms_mod modsDone
914 let mods_to_zap_names
915 = findPartiallyCompletedCycles modsDone_names
918 = filter ((`notElem` mods_to_zap_names).ms_mod)
921 let hpt4 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep)
924 -- Clean up after ourselves
925 liftIO $ cleanTempFilesExcept dflags (ppFilesFromSummaries mods_to_keep)
927 -- there should be no Nothings where linkables should be, now
928 ASSERT(all (isJust.hm_linkable)
929 (eltsUFM (hsc_HPT hsc_env))) do
931 -- Link everything together
932 linkresult <- liftIO $ link (ghcLink dflags) dflags False hpt4
934 let hsc_env4 = hsc_env1{ hsc_HPT = hpt4 }
935 loadFinish Failed linkresult hsc_env4
937 -- Finish up after a load.
939 -- If the link failed, unload everything and return.
940 loadFinish :: GhcMonad m =>
941 SuccessFlag -> SuccessFlag -> HscEnv
943 loadFinish _all_ok Failed hsc_env
944 = do liftIO $ unload hsc_env []
945 modifySession $ \_ -> discardProg hsc_env
948 -- Empty the interactive context and set the module context to the topmost
949 -- newly loaded module, or the Prelude if none were loaded.
950 loadFinish all_ok Succeeded hsc_env
951 = do modifySession $ \_ -> hsc_env{ hsc_IC = emptyInteractiveContext }
955 -- Forget the current program, but retain the persistent info in HscEnv
956 discardProg :: HscEnv -> HscEnv
958 = hsc_env { hsc_mod_graph = emptyMG,
959 hsc_IC = emptyInteractiveContext,
960 hsc_HPT = emptyHomePackageTable }
962 -- used to fish out the preprocess output files for the purposes of
963 -- cleaning up. The preprocessed file *might* be the same as the
964 -- source file, but that doesn't do any harm.
965 ppFilesFromSummaries :: [ModSummary] -> [FilePath]
966 ppFilesFromSummaries summaries = map ms_hspp_file summaries
968 -- -----------------------------------------------------------------------------
970 class ParsedMod m where
971 modSummary :: m -> ModSummary
972 parsedSource :: m -> ParsedSource
974 class ParsedMod m => TypecheckedMod m where
975 renamedSource :: m -> Maybe RenamedSource
976 typecheckedSource :: m -> TypecheckedSource
977 moduleInfo :: m -> ModuleInfo
978 tm_internals :: m -> (TcGblEnv, ModDetails)
979 -- ToDo: improvements that could be made here:
980 -- if the module succeeded renaming but not typechecking,
981 -- we can still get back the GlobalRdrEnv and exports, so
982 -- perhaps the ModuleInfo should be split up into separate
985 class TypecheckedMod m => DesugaredMod m where
986 coreModule :: m -> ModGuts
988 -- | The result of successful parsing.
990 ParsedModule { pm_mod_summary :: ModSummary
991 , pm_parsed_source :: ParsedSource }
993 instance ParsedMod ParsedModule where
994 modSummary m = pm_mod_summary m
995 parsedSource m = pm_parsed_source m
997 -- | The result of successful typechecking. It also contains the parser
999 data TypecheckedModule =
1000 TypecheckedModule { tm_parsed_module :: ParsedModule
1001 , tm_renamed_source :: Maybe RenamedSource
1002 , tm_typechecked_source :: TypecheckedSource
1003 , tm_checked_module_info :: ModuleInfo
1004 , tm_internals_ :: (TcGblEnv, ModDetails)
1007 instance ParsedMod TypecheckedModule where
1008 modSummary m = modSummary (tm_parsed_module m)
1009 parsedSource m = parsedSource (tm_parsed_module m)
1011 instance TypecheckedMod TypecheckedModule where
1012 renamedSource m = tm_renamed_source m
1013 typecheckedSource m = tm_typechecked_source m
1014 moduleInfo m = tm_checked_module_info m
1015 tm_internals m = tm_internals_ m
1017 -- | The result of successful desugaring (i.e., translation to core). Also
1018 -- contains all the information of a typechecked module.
1019 data DesugaredModule =
1020 DesugaredModule { dm_typechecked_module :: TypecheckedModule
1021 , dm_core_module :: ModGuts
1024 instance ParsedMod DesugaredModule where
1025 modSummary m = modSummary (dm_typechecked_module m)
1026 parsedSource m = parsedSource (dm_typechecked_module m)
1028 instance TypecheckedMod DesugaredModule where
1029 renamedSource m = renamedSource (dm_typechecked_module m)
1030 typecheckedSource m = typecheckedSource (dm_typechecked_module m)
1031 moduleInfo m = moduleInfo (dm_typechecked_module m)
1032 tm_internals m = tm_internals_ (dm_typechecked_module m)
1034 instance DesugaredMod DesugaredModule where
1035 coreModule m = dm_core_module m
1037 type ParsedSource = Located (HsModule RdrName)
1038 type RenamedSource = (HsGroup Name, [LImportDecl Name], Maybe [LIE Name],
1039 Maybe (HsDoc Name), HaddockModInfo Name)
1040 type TypecheckedSource = LHsBinds Id
1043 -- - things that aren't in the output of the typechecker right now:
1044 -- - the export list
1046 -- - type signatures
1047 -- - type/data/newtype declarations
1048 -- - class declarations
1050 -- - extra things in the typechecker's output:
1051 -- - default methods are turned into top-level decls.
1052 -- - dictionary bindings
1054 -- | Return the 'ModSummary' of a module with the given name.
1056 -- The module must be part of the module graph (see 'hsc_mod_graph' and
1057 -- 'ModuleGraph'). If this is not the case, this function will throw a
1060 -- This function ignores boot modules and requires that there is only one
1061 -- non-boot module with the given name.
1062 getModSummary :: GhcMonad m => ModuleName -> m ModSummary
1063 getModSummary mod = do
1064 mg <- liftM hsc_mod_graph getSession
1065 case [ ms | ms <- mg, ms_mod_name ms == mod, not (isBootSummary ms) ] of
1066 [] -> throw $ mkApiErr (text "Module not part of module graph")
1068 multiple -> throw $ mkApiErr (text "getModSummary is ambiguous: " <+> ppr multiple)
1070 -- | Parse a module.
1072 -- Throws a 'SourceError' on parse error.
1073 parseModule :: GhcMonad m => ModSummary -> m ParsedModule
1075 rdr_module <- withTempSession
1076 (\e -> e { hsc_dflags = ms_hspp_opts ms }) $
1078 return (ParsedModule ms rdr_module)
1080 -- | Typecheck and rename a parsed module.
1082 -- Throws a 'SourceError' if either fails.
1083 typecheckModule :: GhcMonad m => ParsedModule -> m TypecheckedModule
1084 typecheckModule pmod = do
1085 let ms = modSummary pmod
1086 withTempSession (\e -> e { hsc_dflags = ms_hspp_opts ms }) $ do
1087 (tc_gbl_env, rn_info)
1088 <- hscTypecheckRename ms (parsedSource pmod)
1089 details <- makeSimpleDetails tc_gbl_env
1092 tm_internals_ = (tc_gbl_env, details),
1093 tm_parsed_module = pmod,
1094 tm_renamed_source = rn_info,
1095 tm_typechecked_source = tcg_binds tc_gbl_env,
1096 tm_checked_module_info =
1098 minf_type_env = md_types details,
1099 minf_exports = availsToNameSet $ md_exports details,
1100 minf_rdr_env = Just (tcg_rdr_env tc_gbl_env),
1101 minf_instances = md_insts details
1103 ,minf_modBreaks = emptyModBreaks
1107 -- | Desugar a typechecked module.
1108 desugarModule :: GhcMonad m => TypecheckedModule -> m DesugaredModule
1109 desugarModule tcm = do
1110 let ms = modSummary tcm
1111 withTempSession (\e -> e { hsc_dflags = ms_hspp_opts ms }) $ do
1112 let (tcg, _) = tm_internals tcm
1113 guts <- hscDesugar ms tcg
1116 dm_typechecked_module = tcm,
1117 dm_core_module = guts
1120 -- | Load a module. Input doesn't need to be desugared.
1122 -- A module must be loaded before dependent modules can be typechecked. This
1123 -- always includes generating a 'ModIface' and, depending on the
1124 -- 'DynFlags.hscTarget', may also include code generation.
1126 -- This function will always cause recompilation and will always overwrite
1127 -- previous compilation results (potentially files on disk).
1129 loadModule :: (TypecheckedMod mod, GhcMonad m) => mod -> m mod
1131 let ms = modSummary tcm
1132 let mod = ms_mod_name ms
1133 let (tcg, _details) = tm_internals tcm
1135 withTempSession (\e -> e { hsc_dflags = ms_hspp_opts ms }) $ do
1137 let compilerBackend comp env ms' _ _mb_old_iface _ =
1138 withTempSession (\_ -> env) $
1139 hscBackend comp tcg ms'
1141 hsc_env <- getSession
1143 <- compile' (compilerBackend hscNothingCompiler
1144 ,compilerBackend hscInteractiveCompiler
1145 ,compilerBackend hscBatchCompiler)
1146 hsc_env ms 1 1 Nothing Nothing
1147 -- compile' shouldn't change the environment
1148 return $ addToUFM (hsc_HPT hsc_env) mod mod_info
1149 modifySession $ \e -> e{ hsc_HPT = hpt_new }
1152 -- | This is the way to get access to the Core bindings corresponding
1153 -- to a module. 'compileToCore' parses, typechecks, and
1154 -- desugars the module, then returns the resulting Core module (consisting of
1155 -- the module name, type declarations, and function declarations) if
1157 compileToCoreModule :: GhcMonad m => FilePath -> m CoreModule
1158 compileToCoreModule = compileCore False
1160 -- | Like compileToCoreModule, but invokes the simplifier, so
1161 -- as to return simplified and tidied Core.
1162 compileToCoreSimplified :: GhcMonad m => FilePath -> m CoreModule
1163 compileToCoreSimplified = compileCore True
1165 -- | Provided for backwards-compatibility: compileToCore returns just the Core
1166 -- bindings, but for most purposes, you probably want to call
1167 -- compileToCoreModule.
1168 compileToCore :: GhcMonad m => FilePath -> m [CoreBind]
1169 compileToCore fn = do
1170 mod <- compileToCoreModule session fn
1171 return $ cm_binds mod
1173 -- | Takes a CoreModule and compiles the bindings therein
1174 -- to object code. The first argument is a bool flag indicating
1175 -- whether to run the simplifier.
1176 -- The resulting .o, .hi, and executable files, if any, are stored in the
1177 -- current directory, and named according to the module name.
1178 -- This has only so far been tested with a single self-contained module.
1179 compileCoreToObj :: GhcMonad m => Bool -> CoreModule -> m ()
1180 compileCoreToObj simplify cm@(CoreModule{ cm_module = mName }) = do
1181 dflags <- getSessionDynFlags
1182 currentTime <- liftIO $ getClockTime
1183 cwd <- liftIO $ getCurrentDirectory
1184 modLocation <- liftIO $ mkHiOnlyModLocation dflags (hiSuf dflags) cwd
1185 ((moduleNameSlashes . moduleName) mName)
1187 let modSummary = ModSummary { ms_mod = mName,
1188 ms_hsc_src = ExtCoreFile,
1189 ms_location = modLocation,
1190 -- By setting the object file timestamp to Nothing,
1191 -- we always force recompilation, which is what we
1192 -- want. (Thus it doesn't matter what the timestamp
1193 -- for the (nonexistent) source file is.)
1194 ms_hs_date = currentTime,
1195 ms_obj_date = Nothing,
1196 -- Only handling the single-module case for now, so no imports.
1201 ms_hspp_opts = dflags,
1202 ms_hspp_buf = Nothing
1205 let maybe_simplify mod_guts | simplify = hscSimplify mod_guts
1206 | otherwise = return mod_guts
1207 guts <- maybe_simplify (mkModGuts cm)
1208 (iface, changed, _details, cgguts)
1209 <- hscNormalIface guts Nothing
1210 hscWriteIface iface changed modSummary
1211 _ <- hscGenHardCode cgguts modSummary
1214 -- Makes a "vanilla" ModGuts.
1215 mkModGuts :: CoreModule -> ModGuts
1216 mkModGuts coreModule = ModGuts {
1217 mg_module = cm_module coreModule,
1220 mg_deps = noDependencies,
1221 mg_dir_imps = emptyModuleEnv,
1222 mg_used_names = emptyNameSet,
1223 mg_rdr_env = emptyGlobalRdrEnv,
1224 mg_fix_env = emptyFixityEnv,
1225 mg_types = emptyTypeEnv,
1229 mg_binds = cm_binds coreModule,
1230 mg_foreign = NoStubs,
1231 mg_warns = NoWarnings,
1233 mg_hpc_info = emptyHpcInfo False,
1234 mg_modBreaks = emptyModBreaks,
1235 mg_vect_info = noVectInfo,
1236 mg_inst_env = emptyInstEnv,
1237 mg_fam_inst_env = emptyFamInstEnv
1240 compileCore :: GhcMonad m => Bool -> FilePath -> m CoreModule
1241 compileCore simplify fn = do
1242 -- First, set the target to the desired filename
1243 target <- guessTarget fn Nothing
1245 _ <- load LoadAllTargets
1246 -- Then find dependencies
1247 modGraph <- depanal [] True
1248 case find ((== fn) . msHsFilePath) modGraph of
1249 Just modSummary -> do
1250 -- Now we have the module name;
1251 -- parse, typecheck and desugar the module
1252 mod_guts <- coreModule `fmap`
1253 -- TODO: space leaky: call hsc* directly?
1254 (desugarModule =<< typecheckModule =<< parseModule modSummary)
1255 liftM gutsToCoreModule $
1258 -- If simplify is true: simplify (hscSimplify), then tidy
1260 hsc_env <- getSession
1261 simpl_guts <- hscSimplify mod_guts
1262 tidy_guts <- liftIO $ tidyProgram hsc_env simpl_guts
1263 return $ Left tidy_guts
1265 return $ Right mod_guts
1267 Nothing -> panic "compileToCoreModule: target FilePath not found in\
1268 module dependency graph"
1269 where -- two versions, based on whether we simplify (thus run tidyProgram,
1270 -- which returns a (CgGuts, ModDetails) pair, or not (in which case
1271 -- we just have a ModGuts.
1272 gutsToCoreModule :: Either (CgGuts, ModDetails) ModGuts -> CoreModule
1273 gutsToCoreModule (Left (cg, md)) = CoreModule {
1274 cm_module = cg_module cg, cm_types = md_types md,
1275 cm_imports = cg_dir_imps cg, cm_binds = cg_binds cg
1277 gutsToCoreModule (Right mg) = CoreModule {
1278 cm_module = mg_module mg, cm_types = mg_types mg,
1279 cm_imports = moduleEnvKeys (mg_dir_imps mg), cm_binds = mg_binds mg
1282 -- ---------------------------------------------------------------------------
1285 unload :: HscEnv -> [Linkable] -> IO ()
1286 unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables'
1287 = case ghcLink (hsc_dflags hsc_env) of
1289 LinkInMemory -> Linker.unload (hsc_dflags hsc_env) stable_linkables
1291 LinkInMemory -> panic "unload: no interpreter"
1292 -- urgh. avoid warnings:
1293 hsc_env stable_linkables
1297 -- -----------------------------------------------------------------------------
1301 Stability tells us which modules definitely do not need to be recompiled.
1302 There are two main reasons for having stability:
1304 - avoid doing a complete upsweep of the module graph in GHCi when
1305 modules near the bottom of the tree have not changed.
1307 - to tell GHCi when it can load object code: we can only load object code
1308 for a module when we also load object code fo all of the imports of the
1309 module. So we need to know that we will definitely not be recompiling
1310 any of these modules, and we can use the object code.
1312 The stability check is as follows. Both stableObject and
1313 stableBCO are used during the upsweep phase later.
1316 stable m = stableObject m || stableBCO m
1319 all stableObject (imports m)
1320 && old linkable does not exist, or is == on-disk .o
1321 && date(on-disk .o) > date(.hs)
1324 all stable (imports m)
1325 && date(BCO) > date(.hs)
1328 These properties embody the following ideas:
1330 - if a module is stable, then:
1332 - if it has been compiled in a previous pass (present in HPT)
1333 then it does not need to be compiled or re-linked.
1335 - if it has not been compiled in a previous pass,
1336 then we only need to read its .hi file from disk and
1337 link it to produce a 'ModDetails'.
1339 - if a modules is not stable, we will definitely be at least
1340 re-linking, and possibly re-compiling it during the 'upsweep'.
1341 All non-stable modules can (and should) therefore be unlinked
1342 before the 'upsweep'.
1344 - Note that objects are only considered stable if they only depend
1345 on other objects. We can't link object code against byte code.
1349 :: HomePackageTable -- HPT from last compilation
1350 -> [SCC ModSummary] -- current module graph (cyclic)
1351 -> [ModuleName] -- all home modules
1352 -> ([ModuleName], -- stableObject
1353 [ModuleName]) -- stableBCO
1355 checkStability hpt sccs all_home_mods = foldl checkSCC ([],[]) sccs
1357 checkSCC (stable_obj, stable_bco) scc0
1358 | stableObjects = (scc_mods ++ stable_obj, stable_bco)
1359 | stableBCOs = (stable_obj, scc_mods ++ stable_bco)
1360 | otherwise = (stable_obj, stable_bco)
1362 scc = flattenSCC scc0
1363 scc_mods = map ms_mod_name scc
1364 home_module m = m `elem` all_home_mods && m `notElem` scc_mods
1366 scc_allimps = nub (filter home_module (concatMap ms_home_allimps scc))
1367 -- all imports outside the current SCC, but in the home pkg
1369 stable_obj_imps = map (`elem` stable_obj) scc_allimps
1370 stable_bco_imps = map (`elem` stable_bco) scc_allimps
1374 && all object_ok scc
1377 and (zipWith (||) stable_obj_imps stable_bco_imps)
1381 | Just t <- ms_obj_date ms = t >= ms_hs_date ms
1385 same_as_prev t = case lookupUFM hpt (ms_mod_name ms) of
1386 Just hmi | Just l <- hm_linkable hmi
1387 -> isObjectLinkable l && t == linkableTime l
1389 -- why '>=' rather than '>' above? If the filesystem stores
1390 -- times to the nearset second, we may occasionally find that
1391 -- the object & source have the same modification time,
1392 -- especially if the source was automatically generated
1393 -- and compiled. Using >= is slightly unsafe, but it matches
1394 -- make's behaviour.
1397 = case lookupUFM hpt (ms_mod_name ms) of
1398 Just hmi | Just l <- hm_linkable hmi ->
1399 not (isObjectLinkable l) &&
1400 linkableTime l >= ms_hs_date ms
1403 -- -----------------------------------------------------------------------------
1405 -- | Prune the HomePackageTable
1407 -- Before doing an upsweep, we can throw away:
1409 -- - For non-stable modules:
1410 -- - all ModDetails, all linked code
1411 -- - all unlinked code that is out of date with respect to
1414 -- This is VERY IMPORTANT otherwise we'll end up requiring 2x the
1415 -- space at the end of the upsweep, because the topmost ModDetails of the
1416 -- old HPT holds on to the entire type environment from the previous
1419 pruneHomePackageTable
1422 -> ([ModuleName],[ModuleName])
1425 pruneHomePackageTable hpt summ (stable_obj, stable_bco)
1428 | is_stable modl = hmi'
1429 | otherwise = hmi'{ hm_details = emptyModDetails }
1431 modl = moduleName (mi_module (hm_iface hmi))
1432 hmi' | Just l <- hm_linkable hmi, linkableTime l < ms_hs_date ms
1433 = hmi{ hm_linkable = Nothing }
1436 where ms = expectJust "prune" (lookupUFM ms_map modl)
1438 ms_map = listToUFM [(ms_mod_name ms, ms) | ms <- summ]
1440 is_stable m = m `elem` stable_obj || m `elem` stable_bco
1442 -- -----------------------------------------------------------------------------
1444 -- Return (names of) all those in modsDone who are part of a cycle
1445 -- as defined by theGraph.
1446 findPartiallyCompletedCycles :: [Module] -> [SCC ModSummary] -> [Module]
1447 findPartiallyCompletedCycles modsDone theGraph
1451 chew ((AcyclicSCC _):rest) = chew rest -- acyclic? not interesting.
1452 chew ((CyclicSCC vs):rest)
1453 = let names_in_this_cycle = nub (map ms_mod vs)
1455 = nub ([done | done <- modsDone,
1456 done `elem` names_in_this_cycle])
1457 chewed_rest = chew rest
1459 if notNull mods_in_this_cycle
1460 && length mods_in_this_cycle < length names_in_this_cycle
1461 then mods_in_this_cycle ++ chewed_rest
1464 -- -----------------------------------------------------------------------------
1468 -- This is where we compile each module in the module graph, in a pass
1469 -- from the bottom to the top of the graph.
1471 -- There better had not be any cyclic groups here -- we check for them.
1475 HscEnv -- ^ Includes initially-empty HPT
1476 -> HomePackageTable -- ^ HPT from last time round (pruned)
1477 -> ([ModuleName],[ModuleName]) -- ^ stable modules (see checkStability)
1478 -> IO () -- ^ How to clean up unwanted tmp files
1479 -> [SCC ModSummary] -- ^ Mods to do (the worklist)
1485 -- 1. A flag whether the complete upsweep was successful.
1486 -- 2. The 'HscEnv' with an updated HPT
1487 -- 3. A list of modules which succeeded loading.
1489 upsweep hsc_env old_hpt stable_mods cleanup sccs = do
1490 (res, hsc_env, done) <- upsweep' hsc_env old_hpt [] sccs 1 (length sccs)
1491 return (res, hsc_env, reverse done)
1494 upsweep' hsc_env _old_hpt done
1496 = return (Succeeded, hsc_env, done)
1498 upsweep' hsc_env _old_hpt done
1499 (CyclicSCC ms:_) _ _
1500 = do liftIO $ fatalErrorMsg (hsc_dflags hsc_env) (cyclicModuleErr ms)
1501 return (Failed, hsc_env, done)
1503 upsweep' hsc_env old_hpt done
1504 (AcyclicSCC mod:mods) mod_index nmods
1505 = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++
1506 -- show (map (moduleUserString.moduleName.mi_module.hm_iface)
1507 -- (moduleEnvElts (hsc_HPT hsc_env)))
1508 let logger = reportModuleCompilationResult (hsc_callbacks hsc_env)
1511 <- handleSourceError
1512 (\err -> do logger mod (Just err); return Nothing) $ do
1513 mod_info <- upsweep_mod hsc_env old_hpt stable_mods
1515 logger mod Nothing -- log warnings
1516 return (Just mod_info)
1518 liftIO cleanup -- Remove unwanted tmp files between compilations
1521 Nothing -> return (Failed, hsc_env, done)
1523 let this_mod = ms_mod_name mod
1525 -- Add new info to hsc_env
1526 hpt1 = addToUFM (hsc_HPT hsc_env) this_mod mod_info
1527 hsc_env1 = hsc_env { hsc_HPT = hpt1 }
1529 -- Space-saving: delete the old HPT entry
1530 -- for mod BUT if mod is a hs-boot
1531 -- node, don't delete it. For the
1532 -- interface, the HPT entry is probaby for the
1533 -- main Haskell source file. Deleting it
1534 -- would force the real module to be recompiled
1536 old_hpt1 | isBootSummary mod = old_hpt
1537 | otherwise = delFromUFM old_hpt this_mod
1541 -- fixup our HomePackageTable after we've finished compiling
1542 -- a mutually-recursive loop. See reTypecheckLoop, below.
1543 hsc_env2 <- liftIO $ reTypecheckLoop hsc_env1 mod done'
1545 upsweep' hsc_env2 old_hpt1 done' mods (mod_index+1) nmods
1547 -- | Compile a single module. Always produce a Linkable for it if
1548 -- successful. If no compilation happened, return the old Linkable.
1549 upsweep_mod :: GhcMonad m =>
1552 -> ([ModuleName],[ModuleName])
1554 -> Int -- index of module
1555 -> Int -- total number of modules
1558 upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods
1560 this_mod_name = ms_mod_name summary
1561 this_mod = ms_mod summary
1562 mb_obj_date = ms_obj_date summary
1563 obj_fn = ml_obj_file (ms_location summary)
1564 hs_date = ms_hs_date summary
1566 is_stable_obj = this_mod_name `elem` stable_obj
1567 is_stable_bco = this_mod_name `elem` stable_bco
1569 old_hmi = lookupUFM old_hpt this_mod_name
1571 -- We're using the dflags for this module now, obtained by
1572 -- applying any options in its LANGUAGE & OPTIONS_GHC pragmas.
1573 dflags = ms_hspp_opts summary
1574 prevailing_target = hscTarget (hsc_dflags hsc_env)
1575 local_target = hscTarget dflags
1577 -- If OPTIONS_GHC contains -fasm or -fvia-C, be careful that
1578 -- we don't do anything dodgy: these should only work to change
1579 -- from -fvia-C to -fasm and vice-versa, otherwise we could
1580 -- end up trying to link object code to byte code.
1581 target = if prevailing_target /= local_target
1582 && (not (isObjectTarget prevailing_target)
1583 || not (isObjectTarget local_target))
1584 then prevailing_target
1587 -- store the corrected hscTarget into the summary
1588 summary' = summary{ ms_hspp_opts = dflags { hscTarget = target } }
1590 -- The old interface is ok if
1591 -- a) we're compiling a source file, and the old HPT
1592 -- entry is for a source file
1593 -- b) we're compiling a hs-boot file
1594 -- Case (b) allows an hs-boot file to get the interface of its
1595 -- real source file on the second iteration of the compilation
1596 -- manager, but that does no harm. Otherwise the hs-boot file
1597 -- will always be recompiled
1602 Just hm_info | isBootSummary summary -> Just iface
1603 | not (mi_boot iface) -> Just iface
1604 | otherwise -> Nothing
1606 iface = hm_iface hm_info
1608 compile_it :: GhcMonad m => Maybe Linkable -> m HomeModInfo
1609 compile_it = compile hsc_env summary' mod_index nmods mb_old_iface
1611 compile_it_discard_iface :: GhcMonad m =>
1612 Maybe Linkable -> m HomeModInfo
1613 compile_it_discard_iface
1614 = compile hsc_env summary' mod_index nmods Nothing
1616 -- With the HscNothing target we create empty linkables to avoid
1617 -- recompilation. We have to detect these to recompile anyway if
1618 -- the target changed since the last compile.
1620 | Just hmi <- old_hmi, Just l <- hm_linkable hmi =
1621 null (linkableUnlinked l)
1623 -- we have no linkable, so it cannot be fake
1626 implies False _ = True
1632 -- Regardless of whether we're generating object code or
1633 -- byte code, we can always use an existing object file
1634 -- if it is *stable* (see checkStability).
1635 | is_stable_obj, Just hmi <- old_hmi -> do
1636 liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
1637 (text "skipping stable obj mod:" <+> ppr this_mod_name)
1639 -- object is stable, and we have an entry in the
1640 -- old HPT: nothing to do
1642 | is_stable_obj, isNothing old_hmi -> do
1643 liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
1644 (text "compiling stable on-disk mod:" <+> ppr this_mod_name)
1645 linkable <- liftIO $ findObjectLinkable this_mod obj_fn
1646 (expectJust "upsweep1" mb_obj_date)
1647 compile_it (Just linkable)
1648 -- object is stable, but we need to load the interface
1649 -- off disk to make a HMI.
1651 | not (isObjectTarget target), is_stable_bco,
1652 (target /= HscNothing) `implies` not is_fake_linkable ->
1653 ASSERT(isJust old_hmi) -- must be in the old_hpt
1654 let Just hmi = old_hmi in do
1655 liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
1656 (text "skipping stable BCO mod:" <+> ppr this_mod_name)
1658 -- BCO is stable: nothing to do
1660 | not (isObjectTarget target),
1661 Just hmi <- old_hmi,
1662 Just l <- hm_linkable hmi,
1663 not (isObjectLinkable l),
1664 (target /= HscNothing) `implies` not is_fake_linkable,
1665 linkableTime l >= ms_hs_date summary -> do
1666 liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
1667 (text "compiling non-stable BCO mod:" <+> ppr this_mod_name)
1669 -- we have an old BCO that is up to date with respect
1670 -- to the source: do a recompilation check as normal.
1672 -- When generating object code, if there's an up-to-date
1673 -- object file on the disk, then we can use it.
1674 -- However, if the object file is new (compared to any
1675 -- linkable we had from a previous compilation), then we
1676 -- must discard any in-memory interface, because this
1677 -- means the user has compiled the source file
1678 -- separately and generated a new interface, that we must
1679 -- read from the disk.
1681 | isObjectTarget target,
1682 Just obj_date <- mb_obj_date,
1683 obj_date >= hs_date -> do
1686 | Just l <- hm_linkable hmi,
1687 isObjectLinkable l && linkableTime l == obj_date -> do
1688 liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
1689 (text "compiling mod with new on-disk obj:" <+> ppr this_mod_name)
1692 liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
1693 (text "compiling mod with new on-disk obj2:" <+> ppr this_mod_name)
1694 linkable <- liftIO $ findObjectLinkable this_mod obj_fn obj_date
1695 compile_it_discard_iface (Just linkable)
1698 liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
1699 (text "compiling mod:" <+> ppr this_mod_name)
1704 -- Filter modules in the HPT
1705 retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable
1706 retainInTopLevelEnvs keep_these hpt
1707 = listToUFM [ (mod, expectJust "retain" mb_mod_info)
1709 , let mb_mod_info = lookupUFM hpt mod
1710 , isJust mb_mod_info ]
1712 -- ---------------------------------------------------------------------------
1713 -- Typecheck module loops
1716 See bug #930. This code fixes a long-standing bug in --make. The
1717 problem is that when compiling the modules *inside* a loop, a data
1718 type that is only defined at the top of the loop looks opaque; but
1719 after the loop is done, the structure of the data type becomes
1722 The difficulty is then that two different bits of code have
1723 different notions of what the data type looks like.
1725 The idea is that after we compile a module which also has an .hs-boot
1726 file, we re-generate the ModDetails for each of the modules that
1727 depends on the .hs-boot file, so that everyone points to the proper
1728 TyCons, Ids etc. defined by the real module, not the boot module.
1729 Fortunately re-generating a ModDetails from a ModIface is easy: the
1730 function TcIface.typecheckIface does exactly that.
1732 Picking the modules to re-typecheck is slightly tricky. Starting from
1733 the module graph consisting of the modules that have already been
1734 compiled, we reverse the edges (so they point from the imported module
1735 to the importing module), and depth-first-search from the .hs-boot
1736 node. This gives us all the modules that depend transitively on the
1737 .hs-boot module, and those are exactly the modules that we need to
1740 Following this fix, GHC can compile itself with --make -O2.
1743 reTypecheckLoop :: HscEnv -> ModSummary -> ModuleGraph -> IO HscEnv
1744 reTypecheckLoop hsc_env ms graph
1745 | not (isBootSummary ms) &&
1746 any (\m -> ms_mod m == this_mod && isBootSummary m) graph
1748 let mss = reachableBackwards (ms_mod_name ms) graph
1749 non_boot = filter (not.isBootSummary) mss
1750 debugTraceMsg (hsc_dflags hsc_env) 2 $
1751 text "Re-typechecking loop: " <> ppr (map ms_mod_name non_boot)
1752 typecheckLoop hsc_env (map ms_mod_name non_boot)
1756 this_mod = ms_mod ms
1758 typecheckLoop :: HscEnv -> [ModuleName] -> IO HscEnv
1759 typecheckLoop hsc_env mods = do
1761 fixIO $ \new_hpt -> do
1762 let new_hsc_env = hsc_env{ hsc_HPT = new_hpt }
1763 mds <- initIfaceCheck new_hsc_env $
1764 mapM (typecheckIface . hm_iface) hmis
1765 let new_hpt = addListToUFM old_hpt
1766 (zip mods [ hmi{ hm_details = details }
1767 | (hmi,details) <- zip hmis mds ])
1769 return hsc_env{ hsc_HPT = new_hpt }
1771 old_hpt = hsc_HPT hsc_env
1772 hmis = map (expectJust "typecheckLoop" . lookupUFM old_hpt) mods
1774 reachableBackwards :: ModuleName -> [ModSummary] -> [ModSummary]
1775 reachableBackwards mod summaries
1776 = [ ms | (ms,_,_) <- reachableG (transposeG graph) root ]
1777 where -- the rest just sets up the graph:
1778 (graph, lookup_node) = moduleGraphNodes False summaries
1779 root = expectJust "reachableBackwards" (lookup_node HsBootFile mod)
1781 -- ---------------------------------------------------------------------------
1782 -- Topological sort of the module graph
1784 type SummaryNode = (ModSummary, Int, [Int])
1788 -- ^ Drop hi-boot nodes? (see below)
1791 -- ^ Root module name. If @Nothing@, use the full graph.
1793 -- ^ Calculate SCCs of the module graph, possibly dropping the hi-boot nodes
1794 -- The resulting list of strongly-connected-components is in topologically
1795 -- sorted order, starting with the module(s) at the bottom of the
1796 -- dependency graph (ie compile them first) and ending with the ones at
1799 -- Drop hi-boot nodes (first boolean arg)?
1801 -- - @False@: treat the hi-boot summaries as nodes of the graph,
1802 -- so the graph must be acyclic
1804 -- - @True@: eliminate the hi-boot nodes, and instead pretend
1805 -- the a source-import of Foo is an import of Foo
1806 -- The resulting graph has no hi-boot nodes, but can be cyclic
1808 topSortModuleGraph drop_hs_boot_nodes summaries mb_root_mod
1809 = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph
1811 (graph, lookup_node) = moduleGraphNodes drop_hs_boot_nodes summaries
1813 initial_graph = case mb_root_mod of
1816 -- restrict the graph to just those modules reachable from
1817 -- the specified module. We do this by building a graph with
1818 -- the full set of nodes, and determining the reachable set from
1819 -- the specified node.
1820 let root | Just node <- lookup_node HsSrcFile root_mod, graph `hasVertexG` node = node
1821 | otherwise = ghcError (ProgramError "module does not exist")
1822 in graphFromEdgedVertices (seq root (reachableG graph root))
1824 summaryNodeKey :: SummaryNode -> Int
1825 summaryNodeKey (_, k, _) = k
1827 summaryNodeSummary :: SummaryNode -> ModSummary
1828 summaryNodeSummary (s, _, _) = s
1830 moduleGraphNodes :: Bool -> [ModSummary]
1831 -> (Graph SummaryNode, HscSource -> ModuleName -> Maybe SummaryNode)
1832 moduleGraphNodes drop_hs_boot_nodes summaries = (graphFromEdgedVertices nodes, lookup_node)
1834 numbered_summaries = zip summaries [1..]
1836 lookup_node :: HscSource -> ModuleName -> Maybe SummaryNode
1837 lookup_node hs_src mod = lookupFM node_map (mod, hs_src)
1839 lookup_key :: HscSource -> ModuleName -> Maybe Int
1840 lookup_key hs_src mod = fmap summaryNodeKey (lookup_node hs_src mod)
1842 node_map :: NodeMap SummaryNode
1843 node_map = listToFM [ ((moduleName (ms_mod s), ms_hsc_src s), node)
1844 | node@(s, _, _) <- nodes ]
1846 -- We use integers as the keys for the SCC algorithm
1847 nodes :: [SummaryNode]
1848 nodes = [ (s, key, out_keys)
1849 | (s, key) <- numbered_summaries
1850 -- Drop the hi-boot ones if told to do so
1851 , not (isBootSummary s && drop_hs_boot_nodes)
1852 , let out_keys = out_edge_keys hs_boot_key (map unLoc (ms_home_srcimps s)) ++
1853 out_edge_keys HsSrcFile (map unLoc (ms_home_imps s)) ++
1854 (-- see [boot-edges] below
1855 if drop_hs_boot_nodes || ms_hsc_src s == HsBootFile
1857 else case lookup_key HsBootFile (ms_mod_name s) of
1861 -- [boot-edges] if this is a .hs and there is an equivalent
1862 -- .hs-boot, add a link from the former to the latter. This
1863 -- has the effect of detecting bogus cases where the .hs-boot
1864 -- depends on the .hs, by introducing a cycle. Additionally,
1865 -- it ensures that we will always process the .hs-boot before
1866 -- the .hs, and so the HomePackageTable will always have the
1867 -- most up to date information.
1869 -- Drop hs-boot nodes by using HsSrcFile as the key
1870 hs_boot_key | drop_hs_boot_nodes = HsSrcFile
1871 | otherwise = HsBootFile
1873 out_edge_keys :: HscSource -> [ModuleName] -> [Int]
1874 out_edge_keys hi_boot ms = mapCatMaybes (lookup_key hi_boot) ms
1875 -- If we want keep_hi_boot_nodes, then we do lookup_key with
1876 -- the IsBootInterface parameter True; else False
1879 type NodeKey = (ModuleName, HscSource) -- The nodes of the graph are
1880 type NodeMap a = FiniteMap NodeKey a -- keyed by (mod, src_file_type) pairs
1882 msKey :: ModSummary -> NodeKey
1883 msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot }) = (moduleName mod,boot)
1885 mkNodeMap :: [ModSummary] -> NodeMap ModSummary
1886 mkNodeMap summaries = listToFM [ (msKey s, s) | s <- summaries]
1888 nodeMapElts :: NodeMap a -> [a]
1889 nodeMapElts = eltsFM
1891 -- | If there are {-# SOURCE #-} imports between strongly connected
1892 -- components in the topological sort, then those imports can
1893 -- definitely be replaced by ordinary non-SOURCE imports: if SOURCE
1894 -- were necessary, then the edge would be part of a cycle.
1895 warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m ()
1896 warnUnnecessarySourceImports sccs =
1897 logWarnings (listToBag (concatMap (check.flattenSCC) sccs))
1899 let mods_in_this_cycle = map ms_mod_name ms in
1900 [ warn i | m <- ms, i <- ms_home_srcimps m,
1901 unLoc i `notElem` mods_in_this_cycle ]
1903 warn :: Located ModuleName -> WarnMsg
1906 (ptext (sLit "Warning: {-# SOURCE #-} unnecessary in import of ")
1907 <+> quotes (ppr mod))
1909 -----------------------------------------------------------------------------
1910 -- Downsweep (dependency analysis)
1912 -- Chase downwards from the specified root set, returning summaries
1913 -- for all home modules encountered. Only follow source-import
1916 -- We pass in the previous collection of summaries, which is used as a
1917 -- cache to avoid recalculating a module summary if the source is
1920 -- The returned list of [ModSummary] nodes has one node for each home-package
1921 -- module, plus one for any hs-boot files. The imports of these nodes
1922 -- are all there, including the imports of non-home-package modules.
1924 downsweep :: GhcMonad m =>
1926 -> [ModSummary] -- Old summaries
1927 -> [ModuleName] -- Ignore dependencies on these; treat
1928 -- them as if they were package modules
1929 -> Bool -- True <=> allow multiple targets to have
1930 -- the same module name; this is
1931 -- very useful for ghc -M
1933 -- The elts of [ModSummary] all have distinct
1934 -- (Modules, IsBoot) identifiers, unless the Bool is true
1935 -- in which case there can be repeats
1936 downsweep hsc_env old_summaries excl_mods allow_dup_roots
1937 = do -- catch error messages and return them
1938 --handleErrMsg -- should be covered by GhcMonad now
1939 -- (\err_msg -> printBagOfErrors (hsc_dflags hsc_env) (unitBag err_msg) >> return Nothing) $ do
1940 rootSummaries <- mapM getRootSummary roots
1941 let root_map = mkRootMap rootSummaries
1942 checkDuplicates root_map
1943 summs <- loop (concatMap msDeps rootSummaries) root_map
1946 roots = hsc_targets hsc_env
1948 old_summary_map :: NodeMap ModSummary
1949 old_summary_map = mkNodeMap old_summaries
1951 getRootSummary :: GhcMonad m => Target -> m ModSummary
1952 getRootSummary (Target (TargetFile file mb_phase) obj_allowed maybe_buf)
1953 = do exists <- liftIO $ doesFileExist file
1955 then summariseFile hsc_env old_summaries file mb_phase
1956 obj_allowed maybe_buf
1957 else throwOneError $ mkPlainErrMsg noSrcSpan $
1958 text "can't find file:" <+> text file
1959 getRootSummary (Target (TargetModule modl) obj_allowed maybe_buf)
1960 = do maybe_summary <- summariseModule hsc_env old_summary_map False
1961 (L rootLoc modl) obj_allowed
1963 case maybe_summary of
1964 Nothing -> packageModErr modl
1967 rootLoc = mkGeneralSrcSpan (fsLit "<command line>")
1969 -- In a root module, the filename is allowed to diverge from the module
1970 -- name, so we have to check that there aren't multiple root files
1971 -- defining the same module (otherwise the duplicates will be silently
1972 -- ignored, leading to confusing behaviour).
1973 checkDuplicates :: GhcMonad m => NodeMap [ModSummary] -> m ()
1974 checkDuplicates root_map
1975 | allow_dup_roots = return ()
1976 | null dup_roots = return ()
1977 | otherwise = liftIO $ multiRootsErr (head dup_roots)
1979 dup_roots :: [[ModSummary]] -- Each at least of length 2
1980 dup_roots = filterOut isSingleton (nodeMapElts root_map)
1982 loop :: GhcMonad m =>
1983 [(Located ModuleName,IsBootInterface)]
1984 -- Work list: process these modules
1985 -> NodeMap [ModSummary]
1986 -- Visited set; the range is a list because
1987 -- the roots can have the same module names
1988 -- if allow_dup_roots is True
1990 -- The result includes the worklist, except
1991 -- for those mentioned in the visited set
1992 loop [] done = return (concat (nodeMapElts done))
1993 loop ((wanted_mod, is_boot) : ss) done
1994 | Just summs <- lookupFM done key
1995 = if isSingleton summs then
1998 do { liftIO $ multiRootsErr summs; return [] }
2000 = do mb_s <- summariseModule hsc_env old_summary_map
2001 is_boot wanted_mod True
2004 Nothing -> loop ss done
2005 Just s -> loop (msDeps s ++ ss) (addToFM done key [s])
2007 key = (unLoc wanted_mod, if is_boot then HsBootFile else HsSrcFile)
2009 mkRootMap :: [ModSummary] -> NodeMap [ModSummary]
2010 mkRootMap summaries = addListToFM_C (++) emptyFM
2011 [ (msKey s, [s]) | s <- summaries ]
2013 msDeps :: ModSummary -> [(Located ModuleName, IsBootInterface)]
2014 -- (msDeps s) returns the dependencies of the ModSummary s.
2015 -- A wrinkle is that for a {-# SOURCE #-} import we return
2016 -- *both* the hs-boot file
2017 -- *and* the source file
2018 -- as "dependencies". That ensures that the list of all relevant
2019 -- modules always contains B.hs if it contains B.hs-boot.
2020 -- Remember, this pass isn't doing the topological sort. It's
2021 -- just gathering the list of all relevant ModSummaries
2023 concat [ [(m,True), (m,False)] | m <- ms_home_srcimps s ]
2024 ++ [ (m,False) | m <- ms_home_imps s ]
2026 home_imps :: [Located (ImportDecl RdrName)] -> [Located ModuleName]
2027 home_imps imps = [ ideclName i | L _ i <- imps, isNothing (ideclPkgQual i) ]
2029 ms_home_allimps :: ModSummary -> [ModuleName]
2030 ms_home_allimps ms = map unLoc (ms_home_srcimps ms ++ ms_home_imps ms)
2032 ms_home_srcimps :: ModSummary -> [Located ModuleName]
2033 ms_home_srcimps = home_imps . ms_srcimps
2035 ms_home_imps :: ModSummary -> [Located ModuleName]
2036 ms_home_imps = home_imps . ms_imps
2038 -----------------------------------------------------------------------------
2039 -- Summarising modules
2041 -- We have two types of summarisation:
2043 -- * Summarise a file. This is used for the root module(s) passed to
2044 -- cmLoadModules. The file is read, and used to determine the root
2045 -- module name. The module name may differ from the filename.
2047 -- * Summarise a module. We are given a module name, and must provide
2048 -- a summary. The finder is used to locate the file in which the module
2054 -> [ModSummary] -- old summaries
2055 -> FilePath -- source file name
2056 -> Maybe Phase -- start phase
2057 -> Bool -- object code allowed?
2058 -> Maybe (StringBuffer,ClockTime)
2061 summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf
2062 -- we can use a cached summary if one is available and the
2063 -- source file hasn't changed, But we have to look up the summary
2064 -- by source file, rather than module name as we do in summarise.
2065 | Just old_summary <- findSummaryBySourceFile old_summaries file
2067 let location = ms_location old_summary
2069 -- return the cached summary if the source didn't change
2070 src_timestamp <- case maybe_buf of
2071 Just (_,t) -> return t
2072 Nothing -> liftIO $ getModificationTime file
2073 -- The file exists; we checked in getRootSummary above.
2074 -- If it gets removed subsequently, then this
2075 -- getModificationTime may fail, but that's the right
2078 if ms_hs_date old_summary == src_timestamp
2079 then do -- update the object-file timestamp
2081 if isObjectTarget (hscTarget (hsc_dflags hsc_env))
2082 || obj_allowed -- bug #1205
2083 then liftIO $ getObjTimestamp location False
2085 return old_summary{ ms_obj_date = obj_timestamp }
2093 let dflags = hsc_dflags hsc_env
2095 (dflags', hspp_fn, buf)
2096 <- preprocessFile hsc_env file mb_phase maybe_buf
2098 (srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn file
2100 -- Make a ModLocation for this file
2101 location <- liftIO $ mkHomeModLocation dflags mod_name file
2103 -- Tell the Finder cache where it is, so that subsequent calls
2104 -- to findModule will find it, even if it's not on any search path
2105 mod <- liftIO $ addHomeModuleToFinder hsc_env mod_name location
2107 src_timestamp <- case maybe_buf of
2108 Just (_,t) -> return t
2109 Nothing -> liftIO $ getModificationTime file
2110 -- getMofificationTime may fail
2112 -- when the user asks to load a source file by name, we only
2113 -- use an object file if -fobject-code is on. See #1205.
2115 if isObjectTarget (hscTarget (hsc_dflags hsc_env))
2116 || obj_allowed -- bug #1205
2117 then liftIO $ modificationTimeIfExists (ml_obj_file location)
2120 return (ModSummary { ms_mod = mod, ms_hsc_src = HsSrcFile,
2121 ms_location = location,
2122 ms_hspp_file = hspp_fn,
2123 ms_hspp_opts = dflags',
2124 ms_hspp_buf = Just buf,
2125 ms_srcimps = srcimps, ms_imps = the_imps,
2126 ms_hs_date = src_timestamp,
2127 ms_obj_date = obj_timestamp })
2129 findSummaryBySourceFile :: [ModSummary] -> FilePath -> Maybe ModSummary
2130 findSummaryBySourceFile summaries file
2131 = case [ ms | ms <- summaries, HsSrcFile <- [ms_hsc_src ms],
2132 expectJust "findSummaryBySourceFile" (ml_hs_file (ms_location ms)) == file ] of
2136 -- Summarise a module, and pick up source and timestamp.
2140 -> NodeMap ModSummary -- Map of old summaries
2141 -> IsBootInterface -- True <=> a {-# SOURCE #-} import
2142 -> Located ModuleName -- Imported module to be summarised
2143 -> Bool -- object code allowed?
2144 -> Maybe (StringBuffer, ClockTime)
2145 -> [ModuleName] -- Modules to exclude
2146 -> m (Maybe ModSummary) -- Its new summary
2148 summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
2149 obj_allowed maybe_buf excl_mods
2150 | wanted_mod `elem` excl_mods
2153 | Just old_summary <- lookupFM old_summary_map (wanted_mod, hsc_src)
2154 = do -- Find its new timestamp; all the
2155 -- ModSummaries in the old map have valid ml_hs_files
2156 let location = ms_location old_summary
2157 src_fn = expectJust "summariseModule" (ml_hs_file location)
2159 -- check the modification time on the source file, and
2160 -- return the cached summary if it hasn't changed. If the
2161 -- file has disappeared, we need to call the Finder again.
2163 Just (_,t) -> check_timestamp old_summary location src_fn t
2165 m <- liftIO $ System.IO.Error.try (getModificationTime src_fn)
2167 Right t -> check_timestamp old_summary location src_fn t
2168 Left e | isDoesNotExistError e -> find_it
2169 | otherwise -> liftIO $ ioError e
2171 | otherwise = find_it
2173 dflags = hsc_dflags hsc_env
2175 hsc_src = if is_boot then HsBootFile else HsSrcFile
2177 check_timestamp old_summary location src_fn src_timestamp
2178 | ms_hs_date old_summary == src_timestamp = do
2179 -- update the object-file timestamp
2180 obj_timestamp <- liftIO $
2181 if isObjectTarget (hscTarget (hsc_dflags hsc_env))
2182 || obj_allowed -- bug #1205
2183 then getObjTimestamp location is_boot
2185 return (Just old_summary{ ms_obj_date = obj_timestamp })
2187 -- source changed: re-summarise.
2188 new_summary location (ms_mod old_summary) src_fn src_timestamp
2191 -- Don't use the Finder's cache this time. If the module was
2192 -- previously a package module, it may have now appeared on the
2193 -- search path, so we want to consider it to be a home module. If
2194 -- the module was previously a home module, it may have moved.
2195 liftIO $ uncacheModule hsc_env wanted_mod
2196 found <- liftIO $ findImportedModule hsc_env wanted_mod Nothing
2199 | isJust (ml_hs_file location) ->
2201 just_found location mod
2203 -- Drop external-pkg
2204 ASSERT(modulePackageId mod /= thisPackage dflags)
2207 err -> liftIO $ noModError dflags loc wanted_mod err
2210 just_found location mod = do
2211 -- Adjust location to point to the hs-boot source file,
2212 -- hi file, object file, when is_boot says so
2213 let location' | is_boot = addBootSuffixLocn location
2214 | otherwise = location
2215 src_fn = expectJust "summarise2" (ml_hs_file location')
2217 -- Check that it exists
2218 -- It might have been deleted since the Finder last found it
2219 maybe_t <- liftIO $ modificationTimeIfExists src_fn
2221 Nothing -> noHsFileErr loc src_fn
2222 Just t -> new_summary location' mod src_fn t
2225 new_summary location mod src_fn src_timestamp
2227 -- Preprocess the source file and get its imports
2228 -- The dflags' contains the OPTIONS pragmas
2229 (dflags', hspp_fn, buf) <- preprocessFile hsc_env src_fn Nothing maybe_buf
2230 (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn src_fn
2232 when (mod_name /= wanted_mod) $
2233 throwOneError $ mkPlainErrMsg mod_loc $
2234 text "File name does not match module name:"
2235 $$ text "Saw:" <+> quotes (ppr mod_name)
2236 $$ text "Expected:" <+> quotes (ppr wanted_mod)
2238 -- Find the object timestamp, and return the summary
2239 obj_timestamp <- liftIO $
2240 if isObjectTarget (hscTarget (hsc_dflags hsc_env))
2241 || obj_allowed -- bug #1205
2242 then getObjTimestamp location is_boot
2245 return (Just (ModSummary { ms_mod = mod,
2246 ms_hsc_src = hsc_src,
2247 ms_location = location,
2248 ms_hspp_file = hspp_fn,
2249 ms_hspp_opts = dflags',
2250 ms_hspp_buf = Just buf,
2251 ms_srcimps = srcimps,
2253 ms_hs_date = src_timestamp,
2254 ms_obj_date = obj_timestamp }))
2257 getObjTimestamp :: ModLocation -> Bool -> IO (Maybe ClockTime)
2258 getObjTimestamp location is_boot
2259 = if is_boot then return Nothing
2260 else modificationTimeIfExists (ml_obj_file location)
2263 preprocessFile :: GhcMonad m =>
2266 -> Maybe Phase -- ^ Starting phase
2267 -> Maybe (StringBuffer,ClockTime)
2268 -> m (DynFlags, FilePath, StringBuffer)
2269 preprocessFile hsc_env src_fn mb_phase Nothing
2271 (dflags', hspp_fn) <- preprocess hsc_env (src_fn, mb_phase)
2272 buf <- liftIO $ hGetStringBuffer hspp_fn
2273 return (dflags', hspp_fn, buf)
2275 preprocessFile hsc_env src_fn mb_phase (Just (buf, _time))
2277 let dflags = hsc_dflags hsc_env
2278 -- case we bypass the preprocessing stage?
2280 local_opts = getOptions dflags buf src_fn
2282 (dflags', leftovers, warns)
2283 <- parseDynamicNoPackageFlags dflags local_opts
2284 checkProcessArgsResult leftovers
2285 handleFlagWarnings dflags' warns
2289 | Just (Unlit _) <- mb_phase = True
2290 | Nothing <- mb_phase, Unlit _ <- startPhase src_fn = True
2291 -- note: local_opts is only required if there's no Unlit phase
2292 | dopt Opt_Cpp dflags' = True
2293 | dopt Opt_Pp dflags' = True
2296 when needs_preprocessing $
2297 ghcError (ProgramError "buffer needs preprocesing; interactive check disabled")
2299 return (dflags', src_fn, buf)
2302 -----------------------------------------------------------------------------
2304 -----------------------------------------------------------------------------
2306 noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> IO ab
2307 -- ToDo: we don't have a proper line number for this error
2308 noModError dflags loc wanted_mod err
2309 = throwOneError $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err
2311 noHsFileErr :: GhcMonad m => SrcSpan -> String -> m a
2312 noHsFileErr loc path
2313 = throwOneError $ mkPlainErrMsg loc $ text "Can't find" <+> text path
2315 packageModErr :: GhcMonad m => ModuleName -> m a
2317 = throwOneError $ mkPlainErrMsg noSrcSpan $
2318 text "module" <+> quotes (ppr mod) <+> text "is a package module"
2320 multiRootsErr :: [ModSummary] -> IO ()
2321 multiRootsErr [] = panic "multiRootsErr"
2322 multiRootsErr summs@(summ1:_)
2323 = throwOneError $ mkPlainErrMsg noSrcSpan $
2324 text "module" <+> quotes (ppr mod) <+>
2325 text "is defined in multiple files:" <+>
2326 sep (map text files)
2329 files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs
2331 cyclicModuleErr :: [ModSummary] -> SDoc
2333 = hang (ptext (sLit "Module imports form a cycle for modules:"))
2334 2 (vcat (map show_one ms))
2336 show_one ms = sep [ show_mod (ms_hsc_src ms) (ms_mod ms),
2337 nest 2 $ ptext (sLit "imports:") <+>
2338 (pp_imps HsBootFile (ms_srcimps ms)
2339 $$ pp_imps HsSrcFile (ms_imps ms))]
2340 show_mod hsc_src mod = ppr mod <> text (hscSourceString hsc_src)
2341 pp_imps src mods = fsep (map (show_mod src) mods)
2344 -- | Inform GHC that the working directory has changed. GHC will flush
2345 -- its cache of module locations, since it may no longer be valid.
2346 -- Note: if you change the working directory, you should also unload
2347 -- the current program (set targets to empty, followed by load).
2348 workingDirectoryChanged :: GhcMonad m => m ()
2349 workingDirectoryChanged = withSession $ (liftIO . flushFinderCaches)
2351 -- -----------------------------------------------------------------------------
2352 -- inspecting the session
2354 -- | Get the module dependency graph.
2355 getModuleGraph :: GhcMonad m => m ModuleGraph -- ToDo: DiGraph ModSummary
2356 getModuleGraph = liftM hsc_mod_graph getSession
2358 -- | Determines whether a set of modules requires Template Haskell.
2360 -- Note that if the session's 'DynFlags' enabled Template Haskell when
2361 -- 'depanal' was called, then each module in the returned module graph will
2362 -- have Template Haskell enabled whether it is actually needed or not.
2363 needsTemplateHaskell :: ModuleGraph -> Bool
2364 needsTemplateHaskell ms =
2365 any (dopt Opt_TemplateHaskell . ms_hspp_opts) ms
2367 -- | Return @True@ <==> module is loaded.
2368 isLoaded :: GhcMonad m => ModuleName -> m Bool
2369 isLoaded m = withSession $ \hsc_env ->
2370 return $! isJust (lookupUFM (hsc_HPT hsc_env) m)
2372 -- | Return the bindings for the current interactive session.
2373 getBindings :: GhcMonad m => m [TyThing]
2374 getBindings = withSession $ \hsc_env ->
2375 -- we have to implement the shadowing behaviour of ic_tmp_ids here
2376 -- (see InteractiveContext) and the quickest way is to use an OccEnv.
2378 occ_env = mkOccEnv [ (nameOccName (idName id), AnId id)
2379 | id <- ic_tmp_ids (hsc_IC hsc_env) ]
2381 return (occEnvElts occ_env)
2383 getPrintUnqual :: GhcMonad m => m PrintUnqualified
2384 getPrintUnqual = withSession $ \hsc_env ->
2385 return (icPrintUnqual (hsc_dflags hsc_env) (hsc_IC hsc_env))
2387 -- | Container for information about a 'Module'.
2388 data ModuleInfo = ModuleInfo {
2389 minf_type_env :: TypeEnv,
2390 minf_exports :: NameSet, -- ToDo, [AvailInfo] like ModDetails?
2391 minf_rdr_env :: Maybe GlobalRdrEnv, -- Nothing for a compiled/package mod
2392 minf_instances :: [Instance]
2394 ,minf_modBreaks :: ModBreaks
2396 -- ToDo: this should really contain the ModIface too
2398 -- We don't want HomeModInfo here, because a ModuleInfo applies
2399 -- to package modules too.
2401 -- | Request information about a loaded 'Module'
2402 getModuleInfo :: GhcMonad m => Module -> m (Maybe ModuleInfo) -- XXX: Maybe X
2403 getModuleInfo mdl = withSession $ \hsc_env -> do
2404 let mg = hsc_mod_graph hsc_env
2405 if mdl `elem` map ms_mod mg
2406 then liftIO $ getHomeModuleInfo hsc_env (moduleName mdl)
2408 {- if isHomeModule (hsc_dflags hsc_env) mdl
2410 else -} liftIO $ getPackageModuleInfo hsc_env mdl
2411 -- getPackageModuleInfo will attempt to find the interface, so
2412 -- we don't want to call it for a home module, just in case there
2413 -- was a problem loading the module and the interface doesn't
2414 -- exist... hence the isHomeModule test here. (ToDo: reinstate)
2416 getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
2418 getPackageModuleInfo hsc_env mdl = do
2419 (_msgs, mb_avails) <- getModuleExports hsc_env mdl
2421 Nothing -> return Nothing
2423 eps <- readIORef (hsc_EPS hsc_env)
2425 names = availsToNameSet avails
2427 tys = [ ty | name <- concatMap availNames avails,
2428 Just ty <- [lookupTypeEnv pte name] ]
2430 return (Just (ModuleInfo {
2431 minf_type_env = mkTypeEnv tys,
2432 minf_exports = names,
2433 minf_rdr_env = Just $! nameSetToGlobalRdrEnv names (moduleName mdl),
2434 minf_instances = error "getModuleInfo: instances for package module unimplemented",
2435 minf_modBreaks = emptyModBreaks
2438 getPackageModuleInfo _hsc_env _mdl = do
2439 -- bogusly different for non-GHCI (ToDo)
2443 getHomeModuleInfo :: HscEnv -> ModuleName -> IO (Maybe ModuleInfo)
2444 getHomeModuleInfo hsc_env mdl =
2445 case lookupUFM (hsc_HPT hsc_env) mdl of
2446 Nothing -> return Nothing
2448 let details = hm_details hmi
2449 return (Just (ModuleInfo {
2450 minf_type_env = md_types details,
2451 minf_exports = availsToNameSet (md_exports details),
2452 minf_rdr_env = mi_globals $! hm_iface hmi,
2453 minf_instances = md_insts details
2455 ,minf_modBreaks = getModBreaks hmi
2459 -- | The list of top-level entities defined in a module
2460 modInfoTyThings :: ModuleInfo -> [TyThing]
2461 modInfoTyThings minf = typeEnvElts (minf_type_env minf)
2463 modInfoTopLevelScope :: ModuleInfo -> Maybe [Name]
2464 modInfoTopLevelScope minf
2465 = fmap (map gre_name . globalRdrEnvElts) (minf_rdr_env minf)
2467 modInfoExports :: ModuleInfo -> [Name]
2468 modInfoExports minf = nameSetToList $! minf_exports minf
2470 -- | Returns the instances defined by the specified module.
2471 -- Warning: currently unimplemented for package modules.
2472 modInfoInstances :: ModuleInfo -> [Instance]
2473 modInfoInstances = minf_instances
2475 modInfoIsExportedName :: ModuleInfo -> Name -> Bool
2476 modInfoIsExportedName minf name = elemNameSet name (minf_exports minf)
2478 mkPrintUnqualifiedForModule :: GhcMonad m =>
2480 -> m (Maybe PrintUnqualified) -- XXX: returns a Maybe X
2481 mkPrintUnqualifiedForModule minf = withSession $ \hsc_env -> do
2482 return (fmap (mkPrintUnqualified (hsc_dflags hsc_env)) (minf_rdr_env minf))
2484 modInfoLookupName :: GhcMonad m =>
2486 -> m (Maybe TyThing) -- XXX: returns a Maybe X
2487 modInfoLookupName minf name = withSession $ \hsc_env -> do
2488 case lookupTypeEnv (minf_type_env minf) name of
2489 Just tyThing -> return (Just tyThing)
2491 eps <- liftIO $ readIORef (hsc_EPS hsc_env)
2492 return $! lookupType (hsc_dflags hsc_env)
2493 (hsc_HPT hsc_env) (eps_PTE eps) name
2496 modInfoModBreaks :: ModuleInfo -> ModBreaks
2497 modInfoModBreaks = minf_modBreaks
2500 isDictonaryId :: Id -> Bool
2502 = case tcSplitSigmaTy (idType id) of { (_tvs, _theta, tau) -> isDictTy tau }
2504 -- | Looks up a global name: that is, any top-level name in any
2505 -- visible module. Unlike 'lookupName', lookupGlobalName does not use
2506 -- the interactive context, and therefore does not require a preceding
2508 lookupGlobalName :: GhcMonad m => Name -> m (Maybe TyThing)
2509 lookupGlobalName name = withSession $ \hsc_env -> do
2510 liftIO $ lookupTypeHscEnv hsc_env name
2512 findGlobalAnns :: (GhcMonad m, Typeable a) => ([Word8] -> a) -> AnnTarget Name -> m [a]
2513 findGlobalAnns deserialize target = withSession $ \hsc_env -> do
2514 ann_env <- liftIO $ prepareAnnotations hsc_env Nothing
2515 return (findAnns deserialize ann_env target)
2518 -- | get the GlobalRdrEnv for a session
2519 getGRE :: GhcMonad m => m GlobalRdrEnv
2520 getGRE = withSession $ \hsc_env-> return $ ic_rn_gbl_env (hsc_IC hsc_env)
2523 -- -----------------------------------------------------------------------------
2525 -- | Return all /external/ modules available in the package database.
2526 -- Modules from the current session (i.e., from the 'HomePackageTable') are
2528 packageDbModules :: GhcMonad m =>
2529 Bool -- ^ Only consider exposed packages.
2531 packageDbModules only_exposed = do
2532 dflags <- getSessionDynFlags
2533 let pkgs = UFM.eltsUFM (pkgIdMap (pkgState dflags))
2535 [ mkModule pid modname | p <- pkgs
2536 , not only_exposed || exposed p
2537 , pid <- [mkPackageId (package p)]
2538 , modname <- exposedModules p ]
2540 -- -----------------------------------------------------------------------------
2541 -- Misc exported utils
2543 dataConType :: DataCon -> Type
2544 dataConType dc = idType (dataConWrapId dc)
2546 -- | print a 'NamedThing', adding parentheses if the name is an operator.
2547 pprParenSymName :: NamedThing a => a -> SDoc
2548 pprParenSymName a = parenSymOcc (getOccName a) (ppr (getName a))
2550 -- ----------------------------------------------------------------------------
2555 -- - Data and Typeable instances for HsSyn.
2557 -- ToDo: check for small transformations that happen to the syntax in
2558 -- the typechecker (eg. -e ==> negate e, perhaps for fromIntegral)
2560 -- ToDo: maybe use TH syntax instead of IfaceSyn? There's already a way
2561 -- to get from TyCons, Ids etc. to TH syntax (reify).
2563 -- :browse will use either lm_toplev or inspect lm_interface, depending
2564 -- on whether the module is interpreted or not.
2568 -- Extract the filename, stringbuffer content and dynflags associed to a module
2570 -- XXX: Explain pre-conditions
2571 getModuleSourceAndFlags :: GhcMonad m => Module -> m (String, StringBuffer, DynFlags)
2572 getModuleSourceAndFlags mod = do
2573 m <- getModSummary (moduleName mod)
2574 case ml_hs_file $ ms_location m of
2575 Nothing -> throw $ mkApiErr (text "No source available for module " <+> ppr mod)
2576 Just sourceFile -> do
2577 source <- liftIO $ hGetStringBuffer sourceFile
2578 return (sourceFile, source, ms_hspp_opts m)
2581 -- | Return module source as token stream, including comments.
2583 -- The module must be in the module graph and its source must be available.
2584 -- Throws a 'HscTypes.SourceError' on parse error.
2585 getTokenStream :: GhcMonad m => Module -> m [Located Token]
2586 getTokenStream mod = do
2587 (sourceFile, source, flags) <- getModuleSourceAndFlags mod
2588 let startLoc = mkSrcLoc (mkFastString sourceFile) 0 0
2589 case lexTokenStream source startLoc flags of
2590 POk _ ts -> return ts
2591 PFailed span err -> throw $ mkSrcErr (unitBag $ mkPlainErrMsg span err)
2593 -- | Give even more information on the source than 'getTokenStream'
2594 -- This function allows reconstructing the source completely with
2595 -- 'showRichTokenStream'.
2596 getRichTokenStream :: GhcMonad m => Module -> m [(Located Token, String)]
2597 getRichTokenStream mod = do
2598 (sourceFile, source, flags) <- getModuleSourceAndFlags mod
2599 let startLoc = mkSrcLoc (mkFastString sourceFile) 0 0
2600 case lexTokenStream source startLoc flags of
2601 POk _ ts -> return $ addSourceToTokens startLoc source ts
2602 PFailed span err -> throw $ mkSrcErr (unitBag $ mkPlainErrMsg span err)
2604 -- | Given a source location and a StringBuffer corresponding to this
2605 -- location, return a rich token stream with the source associated to the
2607 addSourceToTokens :: SrcLoc -> StringBuffer -> [Located Token]
2608 -> [(Located Token, String)]
2609 addSourceToTokens _ _ [] = []
2610 addSourceToTokens loc buf (t@(L span _) : ts)
2611 | not (isGoodSrcSpan span) = (t,"") : addSourceToTokens loc buf ts
2612 | otherwise = (t,str) : addSourceToTokens newLoc newBuf ts
2614 (newLoc, newBuf, str) = go "" loc buf
2615 start = srcSpanStart span
2616 end = srcSpanEnd span
2617 go acc loc buf | loc < start = go acc nLoc nBuf
2618 | start <= loc && loc < end = go (ch:acc) nLoc nBuf
2619 | otherwise = (loc, buf, reverse acc)
2620 where (ch, nBuf) = nextChar buf
2621 nLoc = advanceSrcLoc loc ch
2624 -- | Take a rich token stream such as produced from 'getRichTokenStream' and
2625 -- return source code almost identical to the original code (except for
2626 -- insignificant whitespace.)
2627 showRichTokenStream :: [(Located Token, String)] -> String
2628 showRichTokenStream ts = go startLoc ts ""
2629 where sourceFile = srcSpanFile (getLoc . fst . head $ ts)
2630 startLoc = mkSrcLoc sourceFile 0 0
2632 go loc ((L span _, str):ts)
2633 | not (isGoodSrcSpan span) = go loc ts
2634 | locLine == tokLine = ((replicate (tokCol - locCol) ' ') ++)
2637 | otherwise = ((replicate (tokLine - locLine) '\n') ++)
2638 . ((replicate tokCol ' ') ++)
2641 where (locLine, locCol) = (srcLocLine loc, srcLocCol loc)
2642 (tokLine, tokCol) = (srcSpanStartLine span, srcSpanStartCol span)
2643 tokEnd = srcSpanEnd span
2645 -- -----------------------------------------------------------------------------
2646 -- Interactive evaluation
2648 -- | Takes a 'ModuleName' and possibly a 'PackageId', and consults the
2649 -- filesystem and package database to find the corresponding 'Module',
2650 -- using the algorithm that is used for an @import@ declaration.
2651 findModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module
2652 findModule mod_name maybe_pkg = withSession $ \hsc_env -> do
2654 dflags = hsc_dflags hsc_env
2655 this_pkg = thisPackage dflags
2658 Just pkg | fsToPackageId pkg /= this_pkg && pkg /= fsLit "this" -> liftIO $ do
2659 res <- findImportedModule hsc_env mod_name maybe_pkg
2661 Found _ m -> return m
2662 err -> noModError dflags noSrcSpan mod_name err
2664 home <- lookupLoadedHomeModule mod_name
2667 Nothing -> liftIO $ do
2668 res <- findImportedModule hsc_env mod_name maybe_pkg
2670 Found loc m | modulePackageId m /= this_pkg -> return m
2671 | otherwise -> modNotLoadedError m loc
2672 err -> noModError dflags noSrcSpan mod_name err
2674 modNotLoadedError :: Module -> ModLocation -> IO a
2675 modNotLoadedError m loc = ghcError $ CmdLineError $ showSDoc $
2676 text "module is not loaded:" <+>
2677 quotes (ppr (moduleName m)) <+>
2678 parens (text (expectJust "modNotLoadedError" (ml_hs_file loc)))
2680 -- | Like 'findModule', but differs slightly when the module refers to
2681 -- a source file, and the file has not been loaded via 'load'. In
2682 -- this case, 'findModule' will throw an error (module not loaded),
2683 -- but 'lookupModule' will check to see whether the module can also be
2684 -- found in a package, and if so, that package 'Module' will be
2685 -- returned. If not, the usual module-not-found error will be thrown.
2687 lookupModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module
2688 lookupModule mod_name (Just pkg) = findModule mod_name (Just pkg)
2689 lookupModule mod_name Nothing = withSession $ \hsc_env -> do
2690 home <- lookupLoadedHomeModule mod_name
2693 Nothing -> liftIO $ do
2694 res <- findExposedPackageModule hsc_env mod_name Nothing
2696 Found _ m -> return m
2697 err -> noModError (hsc_dflags hsc_env) noSrcSpan mod_name err
2699 lookupLoadedHomeModule :: GhcMonad m => ModuleName -> m (Maybe Module)
2700 lookupLoadedHomeModule mod_name = withSession $ \hsc_env ->
2701 case lookupUFM (hsc_HPT hsc_env) mod_name of
2702 Just mod_info -> return (Just (mi_module (hm_iface mod_info)))
2703 _not_a_home_module -> return Nothing
2706 getHistorySpan :: GhcMonad m => History -> m SrcSpan
2707 getHistorySpan h = withSession $ \hsc_env ->
2708 return$ InteractiveEval.getHistorySpan hsc_env h
2710 obtainTermFromVal :: GhcMonad m => Int -> Bool -> Type -> a -> m Term
2711 obtainTermFromVal bound force ty a =
2712 withSession $ \hsc_env ->
2713 liftIO $ InteractiveEval.obtainTermFromVal hsc_env bound force ty a
2715 obtainTermFromId :: GhcMonad m => Int -> Bool -> Id -> m Term
2716 obtainTermFromId bound force id =
2717 withSession $ \hsc_env ->
2718 liftIO $ InteractiveEval.obtainTermFromId hsc_env bound force id
projects / ghc-hetmet.git / blob