1 -- -----------------------------------------------------------------------------
3 -- (c) The University of Glasgow, 2005
7 -- -----------------------------------------------------------------------------
13 defaultCleanupHandler,
16 -- * Flags and settings
17 DynFlags(..), DynFlag(..), Severity(..), GhcMode(..), HscTarget(..), dopt,
23 Target(..), TargetId(..), Phase,
30 -- * Extending the program scope
31 extendGlobalRdrScope, -- :: Session -> [GlobalRdrElt] -> IO ()
32 setGlobalRdrScope, -- :: Session -> [GlobalRdrElt] -> IO ()
33 extendGlobalTypeScope, -- :: Session -> [Id] -> IO ()
34 setGlobalTypeScope, -- :: Session -> [Id] -> IO ()
36 -- * Loading\/compiling the program
38 load, LoadHowMuch(..), SuccessFlag(..), -- also does depanal
39 workingDirectoryChanged,
40 checkModule, CheckedModule(..),
41 TypecheckedSource, ParsedSource, RenamedSource,
43 -- * Inspecting the module structure of the program
44 ModuleGraph, ModSummary(..), ms_mod_name, ModLocation(..),
49 -- * Inspecting modules
54 modInfoPrintUnqualified,
57 modInfoIsExportedName,
62 PrintUnqualified, alwaysQualify,
64 -- * Interactive evaluation
65 getBindings, getPrintUnqual,
68 setContext, getContext,
79 compileExpr, HValue, dynCompileExpr,
83 -- * Abstract syntax elements
89 Module, mkModule, pprModule, moduleName, modulePackageId,
90 ModuleName, mkModuleName, moduleNameString,
94 nameModule, nameParent_maybe, pprParenSymName, nameSrcLoc,
100 isImplicitId, isDeadBinder,
101 isExportedId, isLocalId, isGlobalId,
103 isPrimOpId, isFCallId, isClassOpId_maybe,
104 isDataConWorkId, idDataCon,
105 isBottomingId, isDictonaryId,
106 recordSelectorFieldLabel,
108 -- ** Type constructors
110 tyConTyVars, tyConDataCons, tyConArity,
111 isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon,
113 synTyConDefn, synTyConType, synTyConResKind,
119 -- ** Data constructors
121 dataConSig, dataConType, dataConTyCon, dataConFieldLabels,
122 dataConIsInfix, isVanillaDataCon,
124 StrictnessMark(..), isMarkedStrict,
128 classMethods, classSCTheta, classTvsFds,
133 instanceDFunId, pprInstance, pprInstanceHdr,
135 -- ** Types and Kinds
136 Type, dropForAlls, splitForAllTys, funResultTy, pprParendType,
139 ThetaType, pprThetaArrow,
145 module HsSyn, -- ToDo: remove extraneous bits
149 defaultFixity, maxPrecedence,
153 -- ** Source locations
157 GhcException(..), showGhcException,
167 * inline bits of HscMain here to simplify layering: hscTcExpr, hscStmt.
168 * what StaticFlags should we expose, if any?
171 #include "HsVersions.h"
174 import qualified Linker
175 import Data.Dynamic ( Dynamic )
176 import Linker ( HValue, extendLinkEnv )
177 import TcRnDriver ( tcRnLookupRdrName, tcRnGetInfo,
178 tcRnLookupName, getModuleExports )
179 import RdrName ( plusGlobalRdrEnv, Provenance(..),
180 ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..),
182 import HscMain ( hscParseIdentifier, hscStmt, hscTcExpr, hscKcType )
183 import Name ( nameOccName )
184 import Type ( tidyType )
185 import VarEnv ( emptyTidyEnv )
186 import GHC.Exts ( unsafeCoerce# )
189 import Packages ( initPackages )
190 import NameSet ( NameSet, nameSetToList, elemNameSet )
191 import RdrName ( GlobalRdrEnv, GlobalRdrElt(..), RdrName(..),
192 globalRdrEnvElts, extendGlobalRdrEnv,
195 import Type ( Kind, Type, dropForAlls, PredType, ThetaType,
196 pprThetaArrow, pprParendType, splitForAllTys,
198 import Id ( Id, idType, isImplicitId, isDeadBinder,
199 isExportedId, isLocalId, isGlobalId,
200 isRecordSelector, recordSelectorFieldLabel,
201 isPrimOpId, isFCallId, isClassOpId_maybe,
202 isDataConWorkId, idDataCon,
205 import TysPrim ( alphaTyVars )
206 import TyCon ( TyCon, isClassTyCon, isSynTyCon, isNewTyCon,
207 isPrimTyCon, isFunTyCon, isOpenTyCon, tyConArity,
208 tyConTyVars, tyConDataCons, synTyConDefn,
209 synTyConType, synTyConResKind )
210 import Class ( Class, classSCTheta, classTvsFds, classMethods )
211 import FunDeps ( pprFundeps )
212 import DataCon ( DataCon, dataConWrapId, dataConSig, dataConTyCon,
213 dataConFieldLabels, dataConStrictMarks,
214 dataConIsInfix, isVanillaDataCon )
215 import Name ( Name, nameModule, NamedThing(..), nameParent_maybe,
217 import OccName ( parenSymOcc )
218 import NameEnv ( nameEnvElts )
219 import InstEnv ( Instance, instanceDFunId, pprInstance, pprInstanceHdr )
221 import DriverPipeline
222 import DriverPhases ( Phase(..), isHaskellSrcFilename, startPhase )
223 import HeaderInfo ( getImports, getOptions )
225 import HscMain ( newHscEnv, hscFileCheck, HscChecked(..) )
228 import SysTools ( initSysTools, cleanTempFiles, cleanTempFilesExcept,
232 import PackageConfig ( PackageId, stringToPackageId )
236 import Bag ( unitBag )
237 import ErrUtils ( Severity(..), showPass, fatalErrorMsg, debugTraceMsg,
238 mkPlainErrMsg, printBagOfErrors )
239 import qualified ErrUtils
241 import StringBuffer ( StringBuffer, hGetStringBuffer )
244 import TcType ( tcSplitSigmaTy, isDictTy )
245 import Maybes ( expectJust, mapCatMaybes )
247 import Control.Concurrent
248 import System.Directory ( getModificationTime, doesFileExist )
249 import Data.Maybe ( isJust, isNothing )
250 import Data.List ( partition, nub )
251 import qualified Data.List as List
252 import Control.Monad ( unless, when )
253 import System.Exit ( exitWith, ExitCode(..) )
254 import System.Time ( ClockTime )
255 import Control.Exception as Exception hiding (handle)
258 import System.IO.Error ( isDoesNotExistError )
259 import Prelude hiding (init)
261 #if __GLASGOW_HASKELL__ < 600
262 import System.IO as System.IO.Error ( try )
264 import System.IO.Error ( try )
267 -- -----------------------------------------------------------------------------
268 -- Exception handlers
270 -- | Install some default exception handlers and run the inner computation.
271 -- Unless you want to handle exceptions yourself, you should wrap this around
272 -- the top level of your program. The default handlers output the error
273 -- message(s) to stderr and exit cleanly.
274 defaultErrorHandler :: DynFlags -> IO a -> IO a
275 defaultErrorHandler dflags inner =
276 -- top-level exception handler: any unrecognised exception is a compiler bug.
277 handle (\exception -> do
280 -- an IO exception probably isn't our fault, so don't panic
282 fatalErrorMsg dflags (text (show exception))
283 AsyncException StackOverflow ->
284 fatalErrorMsg dflags (text "stack overflow: use +RTS -K<size> to increase it")
286 fatalErrorMsg dflags (text (show (Panic (show exception))))
287 exitWith (ExitFailure 1)
290 -- program errors: messages with locations attached. Sometimes it is
291 -- convenient to just throw these as exceptions.
292 handleDyn (\dyn -> do printBagOfErrors dflags (unitBag dyn)
293 exitWith (ExitFailure 1)) $
295 -- error messages propagated as exceptions
296 handleDyn (\dyn -> do
299 PhaseFailed _ code -> exitWith code
300 Interrupted -> exitWith (ExitFailure 1)
301 _ -> do fatalErrorMsg dflags (text (show (dyn :: GhcException)))
302 exitWith (ExitFailure 1)
306 -- | Install a default cleanup handler to remove temporary files
307 -- deposited by a GHC run. This is seperate from
308 -- 'defaultErrorHandler', because you might want to override the error
309 -- handling, but still get the ordinary cleanup behaviour.
310 defaultCleanupHandler :: DynFlags -> IO a -> IO a
311 defaultCleanupHandler dflags inner =
312 -- make sure we clean up after ourselves
313 later (unless (dopt Opt_KeepTmpFiles dflags) $
314 do cleanTempFiles dflags
317 -- exceptions will be blocked while we clean the temporary files,
318 -- so there shouldn't be any difficulty if we receive further
323 -- | Starts a new session. A session consists of a set of loaded
324 -- modules, a set of options (DynFlags), and an interactive context.
325 -- ToDo: GhcMode should say "keep typechecked code" and\/or "keep renamed
327 newSession :: GhcMode -> Maybe FilePath -> IO Session
328 newSession mode mb_top_dir = do
330 main_thread <- myThreadId
331 putMVar interruptTargetThread [main_thread]
332 installSignalHandlers
334 dflags0 <- initSysTools mb_top_dir defaultDynFlags
335 dflags <- initDynFlags dflags0
336 env <- newHscEnv dflags{ ghcMode=mode }
340 -- tmp: this breaks the abstraction, but required because DriverMkDepend
341 -- needs to call the Finder. ToDo: untangle this.
342 sessionHscEnv :: Session -> IO HscEnv
343 sessionHscEnv (Session ref) = readIORef ref
345 withSession :: Session -> (HscEnv -> IO a) -> IO a
346 withSession (Session ref) f = do h <- readIORef ref; f h
348 modifySession :: Session -> (HscEnv -> HscEnv) -> IO ()
349 modifySession (Session ref) f = do h <- readIORef ref; writeIORef ref $! f h
351 -- -----------------------------------------------------------------------------
354 -- | Grabs the DynFlags from the Session
355 getSessionDynFlags :: Session -> IO DynFlags
356 getSessionDynFlags s = withSession s (return . hsc_dflags)
358 -- | Updates the DynFlags in a Session. This also reads
359 -- the package database (unless it has already been read),
360 -- and prepares the compilers knowledge about packages. It
361 -- can be called again to load new packages: just add new
362 -- package flags to (packageFlags dflags).
364 -- Returns a list of new packages that may need to be linked in using
365 -- the dynamic linker (see 'linkPackages') as a result of new package
366 -- flags. If you are not doing linking or doing static linking, you
367 -- can ignore the list of packages returned.
369 setSessionDynFlags :: Session -> DynFlags -> IO [PackageId]
370 setSessionDynFlags (Session ref) dflags = do
371 hsc_env <- readIORef ref
372 (dflags', preload) <- initPackages dflags
373 writeIORef ref $! hsc_env{ hsc_dflags = dflags' }
376 -- | If there is no -o option, guess the name of target executable
377 -- by using top-level source file name as a base.
378 guessOutputFile :: Session -> IO ()
379 guessOutputFile s = modifySession s $ \env ->
380 let dflags = hsc_dflags env
381 mod_graph = hsc_mod_graph env
382 mainModuleSrcPath, guessedName :: Maybe String
383 mainModuleSrcPath = do
384 let isMain = (== mainModIs dflags) . ms_mod
385 [ms] <- return (filter isMain mod_graph)
386 ml_hs_file (ms_location ms)
387 guessedName = fmap basenameOf mainModuleSrcPath
389 case outputFile dflags of
391 Nothing -> env { hsc_dflags = dflags { outputFile = guessedName } }
393 -- -----------------------------------------------------------------------------
396 -- ToDo: think about relative vs. absolute file paths. And what
397 -- happens when the current directory changes.
399 -- | Sets the targets for this session. Each target may be a module name
400 -- or a filename. The targets correspond to the set of root modules for
401 -- the program\/library. Unloading the current program is achieved by
402 -- setting the current set of targets to be empty, followed by load.
403 setTargets :: Session -> [Target] -> IO ()
404 setTargets s targets = modifySession s (\h -> h{ hsc_targets = targets })
406 -- | returns the current set of targets
407 getTargets :: Session -> IO [Target]
408 getTargets s = withSession s (return . hsc_targets)
410 -- | Add another target
411 addTarget :: Session -> Target -> IO ()
413 = modifySession s (\h -> h{ hsc_targets = target : hsc_targets h })
416 removeTarget :: Session -> TargetId -> IO ()
417 removeTarget s target_id
418 = modifySession s (\h -> h{ hsc_targets = filter (hsc_targets h) })
420 filter targets = [ t | t@(Target id _) <- targets, id /= target_id ]
422 -- Attempts to guess what Target a string refers to. This function implements
423 -- the --make/GHCi command-line syntax for filenames:
425 -- - if the string looks like a Haskell source filename, then interpret
427 -- - if adding a .hs or .lhs suffix yields the name of an existing file,
429 -- - otherwise interpret the string as a module name
431 guessTarget :: String -> Maybe Phase -> IO Target
432 guessTarget file (Just phase)
433 = return (Target (TargetFile file (Just phase)) Nothing)
434 guessTarget file Nothing
435 | isHaskellSrcFilename file
436 = return (Target (TargetFile file Nothing) Nothing)
438 = do exists <- doesFileExist hs_file
440 then return (Target (TargetFile hs_file Nothing) Nothing)
442 exists <- doesFileExist lhs_file
444 then return (Target (TargetFile lhs_file Nothing) Nothing)
446 return (Target (TargetModule (mkModuleName file)) Nothing)
448 hs_file = file `joinFileExt` "hs"
449 lhs_file = file `joinFileExt` "lhs"
451 -- -----------------------------------------------------------------------------
452 -- Extending the program scope
454 extendGlobalRdrScope :: Session -> [GlobalRdrElt] -> IO ()
455 extendGlobalRdrScope session rdrElts
456 = modifySession session $ \hscEnv ->
457 let global_rdr = hsc_global_rdr_env hscEnv
458 in hscEnv{ hsc_global_rdr_env = foldl extendGlobalRdrEnv global_rdr rdrElts }
460 setGlobalRdrScope :: Session -> [GlobalRdrElt] -> IO ()
461 setGlobalRdrScope session rdrElts
462 = modifySession session $ \hscEnv ->
463 hscEnv{ hsc_global_rdr_env = foldl extendGlobalRdrEnv emptyGlobalRdrEnv rdrElts }
465 extendGlobalTypeScope :: Session -> [Id] -> IO ()
466 extendGlobalTypeScope session ids
467 = modifySession session $ \hscEnv ->
468 let global_type = hsc_global_type_env hscEnv
469 in hscEnv{ hsc_global_type_env = extendTypeEnvWithIds global_type ids }
471 setGlobalTypeScope :: Session -> [Id] -> IO ()
472 setGlobalTypeScope session ids
473 = modifySession session $ \hscEnv ->
474 hscEnv{ hsc_global_type_env = extendTypeEnvWithIds emptyTypeEnv ids }
476 -- -----------------------------------------------------------------------------
477 -- Loading the program
479 -- Perform a dependency analysis starting from the current targets
480 -- and update the session with the new module graph.
481 depanal :: Session -> [ModuleName] -> Bool -> IO (Maybe ModuleGraph)
482 depanal (Session ref) excluded_mods allow_dup_roots = do
483 hsc_env <- readIORef ref
485 dflags = hsc_dflags hsc_env
486 gmode = ghcMode (hsc_dflags hsc_env)
487 targets = hsc_targets hsc_env
488 old_graph = hsc_mod_graph hsc_env
490 showPass dflags "Chasing dependencies"
491 when (gmode == BatchCompile) $
492 debugTraceMsg dflags 2 (hcat [
493 text "Chasing modules from: ",
494 hcat (punctuate comma (map pprTarget targets))])
496 r <- downsweep hsc_env old_graph excluded_mods allow_dup_roots
498 Just mod_graph -> writeIORef ref hsc_env{ hsc_mod_graph = mod_graph }
503 -- | The result of load.
505 = LoadOk Errors -- ^ all specified targets were loaded successfully.
506 | LoadFailed Errors -- ^ not all modules were loaded.
508 type Errors = [String]
510 data ErrMsg = ErrMsg {
511 errMsgSeverity :: Severity, -- warning, error, etc.
512 errMsgSpans :: [SrcSpan],
513 errMsgShortDoc :: Doc,
514 errMsgExtraInfo :: Doc
520 | LoadUpTo ModuleName
521 | LoadDependenciesOf ModuleName
523 -- | Try to load the program. If a Module is supplied, then just
524 -- attempt to load up to this target. If no Module is supplied,
525 -- then try to load all targets.
526 load :: Session -> LoadHowMuch -> IO SuccessFlag
527 load s@(Session ref) how_much
529 -- Dependency analysis first. Note that this fixes the module graph:
530 -- even if we don't get a fully successful upsweep, the full module
531 -- graph is still retained in the Session. We can tell which modules
532 -- were successfully loaded by inspecting the Session's HPT.
533 mb_graph <- depanal s [] False
535 Just mod_graph -> load2 s how_much mod_graph
536 Nothing -> return Failed
538 load2 s@(Session ref) how_much mod_graph = do
540 hsc_env <- readIORef ref
542 let hpt1 = hsc_HPT hsc_env
543 let dflags = hsc_dflags hsc_env
544 let ghci_mode = ghcMode dflags -- this never changes
546 -- The "bad" boot modules are the ones for which we have
547 -- B.hs-boot in the module graph, but no B.hs
548 -- The downsweep should have ensured this does not happen
550 let all_home_mods = [ms_mod_name s
551 | s <- mod_graph, not (isBootSummary s)]
553 bad_boot_mods = [s | s <- mod_graph, isBootSummary s,
554 not (ms_mod_name s `elem` all_home_mods)]
556 ASSERT( null bad_boot_mods ) return ()
558 -- mg2_with_srcimps drops the hi-boot nodes, returning a
559 -- graph with cycles. Among other things, it is used for
560 -- backing out partially complete cycles following a failed
561 -- upsweep, and for removing from hpt all the modules
562 -- not in strict downwards closure, during calls to compile.
563 let mg2_with_srcimps :: [SCC ModSummary]
564 mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing
566 -- check the stability property for each module.
567 stable_mods@(stable_obj,stable_bco)
568 | BatchCompile <- ghci_mode = ([],[])
569 | otherwise = checkStability hpt1 mg2_with_srcimps all_home_mods
571 -- prune bits of the HPT which are definitely redundant now,
573 pruned_hpt = pruneHomePackageTable hpt1
574 (flattenSCCs mg2_with_srcimps)
579 debugTraceMsg dflags 2 (text "Stable obj:" <+> ppr stable_obj $$
580 text "Stable BCO:" <+> ppr stable_bco)
582 -- Unload any modules which are going to be re-linked this time around.
583 let stable_linkables = [ linkable
584 | m <- stable_obj++stable_bco,
585 Just hmi <- [lookupUFM pruned_hpt m],
586 Just linkable <- [hm_linkable hmi] ]
587 unload hsc_env stable_linkables
589 -- We could at this point detect cycles which aren't broken by
590 -- a source-import, and complain immediately, but it seems better
591 -- to let upsweep_mods do this, so at least some useful work gets
592 -- done before the upsweep is abandoned.
593 --hPutStrLn stderr "after tsort:\n"
594 --hPutStrLn stderr (showSDoc (vcat (map ppr mg2)))
596 -- Now do the upsweep, calling compile for each module in
597 -- turn. Final result is version 3 of everything.
599 -- Topologically sort the module graph, this time including hi-boot
600 -- nodes, and possibly just including the portion of the graph
601 -- reachable from the module specified in the 2nd argument to load.
602 -- This graph should be cycle-free.
603 -- If we're restricting the upsweep to a portion of the graph, we
604 -- also want to retain everything that is still stable.
605 let full_mg :: [SCC ModSummary]
606 full_mg = topSortModuleGraph False mod_graph Nothing
608 maybe_top_mod = case how_much of
610 LoadDependenciesOf m -> Just m
613 partial_mg0 :: [SCC ModSummary]
614 partial_mg0 = topSortModuleGraph False mod_graph maybe_top_mod
616 -- LoadDependenciesOf m: we want the upsweep to stop just
617 -- short of the specified module (unless the specified module
620 | LoadDependenciesOf mod <- how_much
621 = ASSERT( case last partial_mg0 of
622 AcyclicSCC ms -> ms_mod_name ms == mod; _ -> False )
623 List.init partial_mg0
629 | AcyclicSCC ms <- full_mg,
630 ms_mod_name ms `elem` stable_obj++stable_bco,
631 ms_mod_name ms `notElem` [ ms_mod_name ms' |
632 AcyclicSCC ms' <- partial_mg ] ]
634 mg = stable_mg ++ partial_mg
636 -- clean up between compilations
637 let cleanup = cleanTempFilesExcept dflags
638 (ppFilesFromSummaries (flattenSCCs mg2_with_srcimps))
640 (upsweep_ok, hsc_env1, modsUpswept)
641 <- upsweep (hsc_env { hsc_HPT = emptyHomePackageTable })
642 pruned_hpt stable_mods cleanup mg
644 -- Make modsDone be the summaries for each home module now
645 -- available; this should equal the domain of hpt3.
646 -- Get in in a roughly top .. bottom order (hence reverse).
648 let modsDone = reverse modsUpswept
650 -- Try and do linking in some form, depending on whether the
651 -- upsweep was completely or only partially successful.
653 if succeeded upsweep_ok
656 -- Easy; just relink it all.
657 do debugTraceMsg dflags 2 (text "Upsweep completely successful.")
659 -- Clean up after ourselves
660 cleanTempFilesExcept dflags (ppFilesFromSummaries modsDone)
662 -- Issue a warning for the confusing case where the user
663 -- said '-o foo' but we're not going to do any linking.
664 -- We attempt linking if either (a) one of the modules is
665 -- called Main, or (b) the user said -no-hs-main, indicating
666 -- that main() is going to come from somewhere else.
668 let ofile = outputFile dflags
669 let no_hs_main = dopt Opt_NoHsMain dflags
671 main_mod = mainModIs dflags
672 a_root_is_Main = any ((==main_mod).ms_mod) mod_graph
673 do_linking = a_root_is_Main || no_hs_main
675 when (ghci_mode == BatchCompile && isJust ofile && not do_linking) $
676 debugTraceMsg dflags 1 (text ("Warning: output was redirected with -o, " ++
677 "but no output will be generated\n" ++
678 "because there is no " ++ moduleNameString (moduleName main_mod) ++ " module."))
680 -- link everything together
681 linkresult <- link ghci_mode dflags do_linking (hsc_HPT hsc_env1)
683 loadFinish Succeeded linkresult ref hsc_env1
686 -- Tricky. We need to back out the effects of compiling any
687 -- half-done cycles, both so as to clean up the top level envs
688 -- and to avoid telling the interactive linker to link them.
689 do debugTraceMsg dflags 2 (text "Upsweep partially successful.")
692 = map ms_mod modsDone
693 let mods_to_zap_names
694 = findPartiallyCompletedCycles modsDone_names
697 = filter ((`notElem` mods_to_zap_names).ms_mod)
700 let hpt4 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep)
703 -- Clean up after ourselves
704 cleanTempFilesExcept dflags (ppFilesFromSummaries mods_to_keep)
706 -- there should be no Nothings where linkables should be, now
707 ASSERT(all (isJust.hm_linkable)
708 (eltsUFM (hsc_HPT hsc_env))) do
710 -- Link everything together
711 linkresult <- link ghci_mode dflags False hpt4
713 let hsc_env4 = hsc_env1{ hsc_HPT = hpt4 }
714 loadFinish Failed linkresult ref hsc_env4
716 -- Finish up after a load.
718 -- If the link failed, unload everything and return.
719 loadFinish all_ok Failed ref hsc_env
720 = do unload hsc_env []
721 writeIORef ref $! discardProg hsc_env
724 -- Empty the interactive context and set the module context to the topmost
725 -- newly loaded module, or the Prelude if none were loaded.
726 loadFinish all_ok Succeeded ref hsc_env
727 = do writeIORef ref $! hsc_env{ hsc_IC = emptyInteractiveContext }
731 -- Forget the current program, but retain the persistent info in HscEnv
732 discardProg :: HscEnv -> HscEnv
734 = hsc_env { hsc_mod_graph = emptyMG,
735 hsc_IC = emptyInteractiveContext,
736 hsc_HPT = emptyHomePackageTable }
738 -- used to fish out the preprocess output files for the purposes of
739 -- cleaning up. The preprocessed file *might* be the same as the
740 -- source file, but that doesn't do any harm.
741 ppFilesFromSummaries summaries = map ms_hspp_file summaries
743 -- -----------------------------------------------------------------------------
747 CheckedModule { parsedSource :: ParsedSource,
748 renamedSource :: Maybe RenamedSource,
749 typecheckedSource :: Maybe TypecheckedSource,
750 checkedModuleInfo :: Maybe ModuleInfo
752 -- ToDo: improvements that could be made here:
753 -- if the module succeeded renaming but not typechecking,
754 -- we can still get back the GlobalRdrEnv and exports, so
755 -- perhaps the ModuleInfo should be split up into separate
756 -- fields within CheckedModule.
758 type ParsedSource = Located (HsModule RdrName)
759 type RenamedSource = (HsGroup Name, [LImportDecl Name], Maybe [LIE Name])
760 type TypecheckedSource = LHsBinds Id
763 -- - things that aren't in the output of the typechecker right now:
767 -- - type/data/newtype declarations
768 -- - class declarations
770 -- - extra things in the typechecker's output:
771 -- - default methods are turned into top-level decls.
772 -- - dictionary bindings
775 -- | This is the way to get access to parsed and typechecked source code
776 -- for a module. 'checkModule' loads all the dependencies of the specified
777 -- module in the Session, and then attempts to typecheck the module. If
778 -- successful, it returns the abstract syntax for the module.
779 checkModule :: Session -> ModuleName -> IO (Maybe CheckedModule)
780 checkModule session@(Session ref) mod = do
781 -- load up the dependencies first
782 r <- load session (LoadDependenciesOf mod)
783 if (failed r) then return Nothing else do
785 -- now parse & typecheck the module
786 hsc_env <- readIORef ref
787 let mg = hsc_mod_graph hsc_env
788 case [ ms | ms <- mg, ms_mod_name ms == mod ] of
791 mbChecked <- hscFileCheck hsc_env{hsc_dflags=ms_hspp_opts ms} ms
793 Nothing -> return Nothing
794 Just (HscChecked parsed renamed Nothing) ->
795 return (Just (CheckedModule {
796 parsedSource = parsed,
797 renamedSource = renamed,
798 typecheckedSource = Nothing,
799 checkedModuleInfo = Nothing }))
800 Just (HscChecked parsed renamed
801 (Just (tc_binds, rdr_env, details))) -> do
802 let minf = ModuleInfo {
803 minf_type_env = md_types details,
804 minf_exports = md_exports details,
805 minf_rdr_env = Just rdr_env,
806 minf_instances = md_insts details
808 return (Just (CheckedModule {
809 parsedSource = parsed,
810 renamedSource = renamed,
811 typecheckedSource = Just tc_binds,
812 checkedModuleInfo = Just minf }))
814 -- ---------------------------------------------------------------------------
817 unload :: HscEnv -> [Linkable] -> IO ()
818 unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables'
819 = case ghcMode (hsc_dflags hsc_env) of
820 BatchCompile -> return ()
821 JustTypecheck -> return ()
823 Interactive -> Linker.unload (hsc_dflags hsc_env) stable_linkables
825 Interactive -> panic "unload: no interpreter"
827 other -> panic "unload: strange mode"
829 -- -----------------------------------------------------------------------------
833 Stability tells us which modules definitely do not need to be recompiled.
834 There are two main reasons for having stability:
836 - avoid doing a complete upsweep of the module graph in GHCi when
837 modules near the bottom of the tree have not changed.
839 - to tell GHCi when it can load object code: we can only load object code
840 for a module when we also load object code fo all of the imports of the
841 module. So we need to know that we will definitely not be recompiling
842 any of these modules, and we can use the object code.
844 NB. stability is of no importance to BatchCompile at all, only Interactive.
845 (ToDo: what about JustTypecheck?)
847 The stability check is as follows. Both stableObject and
848 stableBCO are used during the upsweep phase later.
851 stable m = stableObject m || stableBCO m
854 all stableObject (imports m)
855 && old linkable does not exist, or is == on-disk .o
856 && date(on-disk .o) > date(.hs)
859 all stable (imports m)
860 && date(BCO) > date(.hs)
863 These properties embody the following ideas:
865 - if a module is stable:
866 - if it has been compiled in a previous pass (present in HPT)
867 then it does not need to be compiled or re-linked.
868 - if it has not been compiled in a previous pass,
869 then we only need to read its .hi file from disk and
870 link it to produce a ModDetails.
872 - if a modules is not stable, we will definitely be at least
873 re-linking, and possibly re-compiling it during the upsweep.
874 All non-stable modules can (and should) therefore be unlinked
877 - Note that objects are only considered stable if they only depend
878 on other objects. We can't link object code against byte code.
882 :: HomePackageTable -- HPT from last compilation
883 -> [SCC ModSummary] -- current module graph (cyclic)
884 -> [ModuleName] -- all home modules
885 -> ([ModuleName], -- stableObject
886 [ModuleName]) -- stableBCO
888 checkStability hpt sccs all_home_mods = foldl checkSCC ([],[]) sccs
890 checkSCC (stable_obj, stable_bco) scc0
891 | stableObjects = (scc_mods ++ stable_obj, stable_bco)
892 | stableBCOs = (stable_obj, scc_mods ++ stable_bco)
893 | otherwise = (stable_obj, stable_bco)
895 scc = flattenSCC scc0
896 scc_mods = map ms_mod_name scc
897 home_module m = m `elem` all_home_mods && m `notElem` scc_mods
899 scc_allimps = nub (filter home_module (concatMap ms_allimps scc))
900 -- all imports outside the current SCC, but in the home pkg
902 stable_obj_imps = map (`elem` stable_obj) scc_allimps
903 stable_bco_imps = map (`elem` stable_bco) scc_allimps
910 and (zipWith (||) stable_obj_imps stable_bco_imps)
914 | Just t <- ms_obj_date ms = t >= ms_hs_date ms
918 same_as_prev t = case lookupUFM hpt (ms_mod_name ms) of
919 Just hmi | Just l <- hm_linkable hmi
920 -> isObjectLinkable l && t == linkableTime l
922 -- why '>=' rather than '>' above? If the filesystem stores
923 -- times to the nearset second, we may occasionally find that
924 -- the object & source have the same modification time,
925 -- especially if the source was automatically generated
926 -- and compiled. Using >= is slightly unsafe, but it matches
930 = case lookupUFM hpt (ms_mod_name ms) of
931 Just hmi | Just l <- hm_linkable hmi ->
932 not (isObjectLinkable l) &&
933 linkableTime l >= ms_hs_date ms
936 ms_allimps :: ModSummary -> [ModuleName]
937 ms_allimps ms = map unLoc (ms_srcimps ms ++ ms_imps ms)
939 -- -----------------------------------------------------------------------------
940 -- Prune the HomePackageTable
942 -- Before doing an upsweep, we can throw away:
944 -- - For non-stable modules:
945 -- - all ModDetails, all linked code
946 -- - all unlinked code that is out of date with respect to
949 -- This is VERY IMPORTANT otherwise we'll end up requiring 2x the
950 -- space at the end of the upsweep, because the topmost ModDetails of the
951 -- old HPT holds on to the entire type environment from the previous
954 pruneHomePackageTable
957 -> ([ModuleName],[ModuleName])
960 pruneHomePackageTable hpt summ (stable_obj, stable_bco)
963 | is_stable modl = hmi'
964 | otherwise = hmi'{ hm_details = emptyModDetails }
966 modl = moduleName (mi_module (hm_iface hmi))
967 hmi' | Just l <- hm_linkable hmi, linkableTime l < ms_hs_date ms
968 = hmi{ hm_linkable = Nothing }
971 where ms = expectJust "prune" (lookupUFM ms_map modl)
973 ms_map = listToUFM [(ms_mod_name ms, ms) | ms <- summ]
975 is_stable m = m `elem` stable_obj || m `elem` stable_bco
977 -- -----------------------------------------------------------------------------
979 -- Return (names of) all those in modsDone who are part of a cycle
980 -- as defined by theGraph.
981 findPartiallyCompletedCycles :: [Module] -> [SCC ModSummary] -> [Module]
982 findPartiallyCompletedCycles modsDone theGraph
986 chew ((AcyclicSCC v):rest) = chew rest -- acyclic? not interesting.
987 chew ((CyclicSCC vs):rest)
988 = let names_in_this_cycle = nub (map ms_mod vs)
990 = nub ([done | done <- modsDone,
991 done `elem` names_in_this_cycle])
992 chewed_rest = chew rest
994 if notNull mods_in_this_cycle
995 && length mods_in_this_cycle < length names_in_this_cycle
996 then mods_in_this_cycle ++ chewed_rest
999 -- -----------------------------------------------------------------------------
1002 -- This is where we compile each module in the module graph, in a pass
1003 -- from the bottom to the top of the graph.
1005 -- There better had not be any cyclic groups here -- we check for them.
1008 :: HscEnv -- Includes initially-empty HPT
1009 -> HomePackageTable -- HPT from last time round (pruned)
1010 -> ([ModuleName],[ModuleName]) -- stable modules (see checkStability)
1011 -> IO () -- How to clean up unwanted tmp files
1012 -> [SCC ModSummary] -- Mods to do (the worklist)
1014 HscEnv, -- With an updated HPT
1015 [ModSummary]) -- Mods which succeeded
1017 upsweep hsc_env old_hpt stable_mods cleanup mods
1018 = upsweep' hsc_env old_hpt stable_mods cleanup mods 1 (length mods)
1020 upsweep' hsc_env old_hpt stable_mods cleanup
1022 = return (Succeeded, hsc_env, [])
1024 upsweep' hsc_env old_hpt stable_mods cleanup
1025 (CyclicSCC ms:_) _ _
1026 = do fatalErrorMsg (hsc_dflags hsc_env) (cyclicModuleErr ms)
1027 return (Failed, hsc_env, [])
1029 upsweep' hsc_env old_hpt stable_mods cleanup
1030 (AcyclicSCC mod:mods) mod_index nmods
1031 = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++
1032 -- show (map (moduleUserString.moduleName.mi_module.hm_iface)
1033 -- (moduleEnvElts (hsc_HPT hsc_env)))
1035 mb_mod_info <- upsweep_mod hsc_env old_hpt stable_mods mod
1038 cleanup -- Remove unwanted tmp files between compilations
1041 Nothing -> return (Failed, hsc_env, [])
1043 { let this_mod = ms_mod_name mod
1045 -- Add new info to hsc_env
1046 hpt1 = addToUFM (hsc_HPT hsc_env) this_mod mod_info
1047 hsc_env1 = hsc_env { hsc_HPT = hpt1 }
1049 -- Space-saving: delete the old HPT entry
1050 -- for mod BUT if mod is a hs-boot
1051 -- node, don't delete it. For the
1052 -- interface, the HPT entry is probaby for the
1053 -- main Haskell source file. Deleting it
1054 -- would force .. (what?? --SDM)
1055 old_hpt1 | isBootSummary mod = old_hpt
1056 | otherwise = delFromUFM old_hpt this_mod
1058 ; (restOK, hsc_env2, modOKs)
1059 <- upsweep' hsc_env1 old_hpt1 stable_mods cleanup
1060 mods (mod_index+1) nmods
1061 ; return (restOK, hsc_env2, mod:modOKs)
1065 -- Compile a single module. Always produce a Linkable for it if
1066 -- successful. If no compilation happened, return the old Linkable.
1067 upsweep_mod :: HscEnv
1069 -> ([ModuleName],[ModuleName])
1071 -> Int -- index of module
1072 -> Int -- total number of modules
1073 -> IO (Maybe HomeModInfo) -- Nothing => Failed
1075 upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods
1078 this_mod_name = ms_mod_name summary
1079 this_mod = ms_mod summary
1080 mb_obj_date = ms_obj_date summary
1081 obj_fn = ml_obj_file (ms_location summary)
1082 hs_date = ms_hs_date summary
1084 compile_it :: Maybe Linkable -> IO (Maybe HomeModInfo)
1085 compile_it = upsweep_compile hsc_env old_hpt this_mod_name
1086 summary mod_index nmods
1088 case ghcMode (hsc_dflags hsc_env) of
1091 -- Batch-compilating is easy: just check whether we have
1092 -- an up-to-date object file. If we do, then the compiler
1093 -- needs to do a recompilation check.
1094 _ | Just obj_date <- mb_obj_date, obj_date >= hs_date -> do
1096 findObjectLinkable this_mod obj_fn obj_date
1097 compile_it (Just linkable)
1104 _ | is_stable_obj, isJust old_hmi ->
1106 -- object is stable, and we have an entry in the
1107 -- old HPT: nothing to do
1109 | is_stable_obj, isNothing old_hmi -> do
1111 findObjectLinkable this_mod obj_fn
1112 (expectJust "upseep1" mb_obj_date)
1113 compile_it (Just linkable)
1114 -- object is stable, but we need to load the interface
1115 -- off disk to make a HMI.
1118 ASSERT(isJust old_hmi) -- must be in the old_hpt
1120 -- BCO is stable: nothing to do
1122 | Just hmi <- old_hmi,
1123 Just l <- hm_linkable hmi, not (isObjectLinkable l),
1124 linkableTime l >= ms_hs_date summary ->
1126 -- we have an old BCO that is up to date with respect
1127 -- to the source: do a recompilation check as normal.
1131 -- no existing code at all: we must recompile.
1133 is_stable_obj = this_mod_name `elem` stable_obj
1134 is_stable_bco = this_mod_name `elem` stable_bco
1136 old_hmi = lookupUFM old_hpt this_mod_name
1138 -- Run hsc to compile a module
1139 upsweep_compile hsc_env old_hpt this_mod summary
1141 mb_old_linkable = do
1143 -- The old interface is ok if it's in the old HPT
1144 -- a) we're compiling a source file, and the old HPT
1145 -- entry is for a source file
1146 -- b) we're compiling a hs-boot file
1147 -- Case (b) allows an hs-boot file to get the interface of its
1148 -- real source file on the second iteration of the compilation
1149 -- manager, but that does no harm. Otherwise the hs-boot file
1150 -- will always be recompiled
1153 = case lookupUFM old_hpt this_mod of
1155 Just hm_info | isBootSummary summary -> Just iface
1156 | not (mi_boot iface) -> Just iface
1157 | otherwise -> Nothing
1159 iface = hm_iface hm_info
1161 compresult <- compile hsc_env summary mb_old_linkable mb_old_iface
1165 -- Compilation failed. Compile may still have updated the PCS, tho.
1166 CompErrs -> return Nothing
1168 -- Compilation "succeeded", and may or may not have returned a new
1169 -- linkable (depending on whether compilation was actually performed
1171 CompOK new_details new_iface new_linkable
1172 -> do let new_info = HomeModInfo { hm_iface = new_iface,
1173 hm_details = new_details,
1174 hm_linkable = new_linkable }
1175 return (Just new_info)
1178 -- Filter modules in the HPT
1179 retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable
1180 retainInTopLevelEnvs keep_these hpt
1181 = listToUFM [ (mod, expectJust "retain" mb_mod_info)
1183 , let mb_mod_info = lookupUFM hpt mod
1184 , isJust mb_mod_info ]
1186 -- ---------------------------------------------------------------------------
1187 -- Topological sort of the module graph
1190 :: Bool -- Drop hi-boot nodes? (see below)
1194 -- Calculate SCCs of the module graph, possibly dropping the hi-boot nodes
1195 -- The resulting list of strongly-connected-components is in topologically
1196 -- sorted order, starting with the module(s) at the bottom of the
1197 -- dependency graph (ie compile them first) and ending with the ones at
1200 -- Drop hi-boot nodes (first boolean arg)?
1202 -- False: treat the hi-boot summaries as nodes of the graph,
1203 -- so the graph must be acyclic
1205 -- True: eliminate the hi-boot nodes, and instead pretend
1206 -- the a source-import of Foo is an import of Foo
1207 -- The resulting graph has no hi-boot nodes, but can by cyclic
1209 topSortModuleGraph drop_hs_boot_nodes summaries Nothing
1210 = stronglyConnComp (fst (moduleGraphNodes drop_hs_boot_nodes summaries))
1211 topSortModuleGraph drop_hs_boot_nodes summaries (Just mod)
1212 = stronglyConnComp (map vertex_fn (reachable graph root))
1214 -- restrict the graph to just those modules reachable from
1215 -- the specified module. We do this by building a graph with
1216 -- the full set of nodes, and determining the reachable set from
1217 -- the specified node.
1218 (nodes, lookup_key) = moduleGraphNodes drop_hs_boot_nodes summaries
1219 (graph, vertex_fn, key_fn) = graphFromEdges' nodes
1221 | Just key <- lookup_key HsSrcFile mod, Just v <- key_fn key = v
1222 | otherwise = throwDyn (ProgramError "module does not exist")
1224 moduleGraphNodes :: Bool -> [ModSummary]
1225 -> ([(ModSummary, Int, [Int])], HscSource -> ModuleName -> Maybe Int)
1226 moduleGraphNodes drop_hs_boot_nodes summaries = (nodes, lookup_key)
1228 -- Drop hs-boot nodes by using HsSrcFile as the key
1229 hs_boot_key | drop_hs_boot_nodes = HsSrcFile
1230 | otherwise = HsBootFile
1232 -- We use integers as the keys for the SCC algorithm
1233 nodes :: [(ModSummary, Int, [Int])]
1234 nodes = [(s, expectJust "topSort" (lookup_key (ms_hsc_src s) (ms_mod_name s)),
1235 out_edge_keys hs_boot_key (map unLoc (ms_srcimps s)) ++
1236 out_edge_keys HsSrcFile (map unLoc (ms_imps s)) )
1238 , not (isBootSummary s && drop_hs_boot_nodes) ]
1239 -- Drop the hi-boot ones if told to do so
1241 key_map :: NodeMap Int
1242 key_map = listToFM ([(moduleName (ms_mod s), ms_hsc_src s)
1246 lookup_key :: HscSource -> ModuleName -> Maybe Int
1247 lookup_key hs_src mod = lookupFM key_map (mod, hs_src)
1249 out_edge_keys :: HscSource -> [ModuleName] -> [Int]
1250 out_edge_keys hi_boot ms = mapCatMaybes (lookup_key hi_boot) ms
1251 -- If we want keep_hi_boot_nodes, then we do lookup_key with
1252 -- the IsBootInterface parameter True; else False
1255 type NodeKey = (ModuleName, HscSource) -- The nodes of the graph are
1256 type NodeMap a = FiniteMap NodeKey a -- keyed by (mod, src_file_type) pairs
1258 msKey :: ModSummary -> NodeKey
1259 msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot }) = (moduleName mod,boot)
1261 mkNodeMap :: [ModSummary] -> NodeMap ModSummary
1262 mkNodeMap summaries = listToFM [ (msKey s, s) | s <- summaries]
1264 nodeMapElts :: NodeMap a -> [a]
1265 nodeMapElts = eltsFM
1267 ms_mod_name :: ModSummary -> ModuleName
1268 ms_mod_name = moduleName . ms_mod
1270 -----------------------------------------------------------------------------
1271 -- Downsweep (dependency analysis)
1273 -- Chase downwards from the specified root set, returning summaries
1274 -- for all home modules encountered. Only follow source-import
1277 -- We pass in the previous collection of summaries, which is used as a
1278 -- cache to avoid recalculating a module summary if the source is
1281 -- The returned list of [ModSummary] nodes has one node for each home-package
1282 -- module, plus one for any hs-boot files. The imports of these nodes
1283 -- are all there, including the imports of non-home-package modules.
1286 -> [ModSummary] -- Old summaries
1287 -> [ModuleName] -- Ignore dependencies on these; treat
1288 -- them as if they were package modules
1289 -> Bool -- True <=> allow multiple targets to have
1290 -- the same module name; this is
1291 -- very useful for ghc -M
1292 -> IO (Maybe [ModSummary])
1293 -- The elts of [ModSummary] all have distinct
1294 -- (Modules, IsBoot) identifiers, unless the Bool is true
1295 -- in which case there can be repeats
1296 downsweep hsc_env old_summaries excl_mods allow_dup_roots
1297 = -- catch error messages and return them
1298 handleDyn (\err_msg -> printBagOfErrors (hsc_dflags hsc_env) (unitBag err_msg) >> return Nothing) $ do
1299 rootSummaries <- mapM getRootSummary roots
1300 let root_map = mkRootMap rootSummaries
1301 checkDuplicates root_map
1302 summs <- loop (concatMap msDeps rootSummaries) root_map
1305 roots = hsc_targets hsc_env
1307 old_summary_map :: NodeMap ModSummary
1308 old_summary_map = mkNodeMap old_summaries
1310 getRootSummary :: Target -> IO ModSummary
1311 getRootSummary (Target (TargetFile file mb_phase) maybe_buf)
1312 = do exists <- doesFileExist file
1314 then summariseFile hsc_env old_summaries file mb_phase maybe_buf
1315 else throwDyn $ mkPlainErrMsg noSrcSpan $
1316 text "can't find file:" <+> text file
1317 getRootSummary (Target (TargetModule modl) maybe_buf)
1318 = do maybe_summary <- summariseModule hsc_env old_summary_map False
1319 (L rootLoc modl) maybe_buf excl_mods
1320 case maybe_summary of
1321 Nothing -> packageModErr modl
1324 rootLoc = mkGeneralSrcSpan FSLIT("<command line>")
1326 -- In a root module, the filename is allowed to diverge from the module
1327 -- name, so we have to check that there aren't multiple root files
1328 -- defining the same module (otherwise the duplicates will be silently
1329 -- ignored, leading to confusing behaviour).
1330 checkDuplicates :: NodeMap [ModSummary] -> IO ()
1331 checkDuplicates root_map
1332 | allow_dup_roots = return ()
1333 | null dup_roots = return ()
1334 | otherwise = multiRootsErr (head dup_roots)
1336 dup_roots :: [[ModSummary]] -- Each at least of length 2
1337 dup_roots = filterOut isSingleton (nodeMapElts root_map)
1339 loop :: [(Located ModuleName,IsBootInterface)]
1340 -- Work list: process these modules
1341 -> NodeMap [ModSummary]
1342 -- Visited set; the range is a list because
1343 -- the roots can have the same module names
1344 -- if allow_dup_roots is True
1346 -- The result includes the worklist, except
1347 -- for those mentioned in the visited set
1348 loop [] done = return (concat (nodeMapElts done))
1349 loop ((wanted_mod, is_boot) : ss) done
1350 | Just summs <- lookupFM done key
1351 = if isSingleton summs then
1354 do { multiRootsErr summs; return [] }
1355 | otherwise = do { mb_s <- summariseModule hsc_env old_summary_map
1356 is_boot wanted_mod Nothing excl_mods
1358 Nothing -> loop ss done
1359 Just s -> loop (msDeps s ++ ss)
1360 (addToFM done key [s]) }
1362 key = (unLoc wanted_mod, if is_boot then HsBootFile else HsSrcFile)
1364 mkRootMap :: [ModSummary] -> NodeMap [ModSummary]
1365 mkRootMap summaries = addListToFM_C (++) emptyFM
1366 [ (msKey s, [s]) | s <- summaries ]
1368 msDeps :: ModSummary -> [(Located ModuleName, IsBootInterface)]
1369 -- (msDeps s) returns the dependencies of the ModSummary s.
1370 -- A wrinkle is that for a {-# SOURCE #-} import we return
1371 -- *both* the hs-boot file
1372 -- *and* the source file
1373 -- as "dependencies". That ensures that the list of all relevant
1374 -- modules always contains B.hs if it contains B.hs-boot.
1375 -- Remember, this pass isn't doing the topological sort. It's
1376 -- just gathering the list of all relevant ModSummaries
1378 concat [ [(m,True), (m,False)] | m <- ms_srcimps s ]
1379 ++ [ (m,False) | m <- ms_imps s ]
1381 -----------------------------------------------------------------------------
1382 -- Summarising modules
1384 -- We have two types of summarisation:
1386 -- * Summarise a file. This is used for the root module(s) passed to
1387 -- cmLoadModules. The file is read, and used to determine the root
1388 -- module name. The module name may differ from the filename.
1390 -- * Summarise a module. We are given a module name, and must provide
1391 -- a summary. The finder is used to locate the file in which the module
1396 -> [ModSummary] -- old summaries
1397 -> FilePath -- source file name
1398 -> Maybe Phase -- start phase
1399 -> Maybe (StringBuffer,ClockTime)
1402 summariseFile hsc_env old_summaries file mb_phase maybe_buf
1403 -- we can use a cached summary if one is available and the
1404 -- source file hasn't changed, But we have to look up the summary
1405 -- by source file, rather than module name as we do in summarise.
1406 | Just old_summary <- findSummaryBySourceFile old_summaries file
1408 let location = ms_location old_summary
1410 -- return the cached summary if the source didn't change
1411 src_timestamp <- case maybe_buf of
1412 Just (_,t) -> return t
1413 Nothing -> getModificationTime file
1414 -- The file exists; we checked in getRootSummary above.
1415 -- If it gets removed subsequently, then this
1416 -- getModificationTime may fail, but that's the right
1419 if ms_hs_date old_summary == src_timestamp
1420 then do -- update the object-file timestamp
1421 obj_timestamp <- getObjTimestamp location False
1422 return old_summary{ ms_obj_date = obj_timestamp }
1430 let dflags = hsc_dflags hsc_env
1432 (dflags', hspp_fn, buf)
1433 <- preprocessFile dflags file mb_phase maybe_buf
1435 (srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn
1437 -- Make a ModLocation for this file
1438 location <- mkHomeModLocation dflags mod_name file
1440 -- Tell the Finder cache where it is, so that subsequent calls
1441 -- to findModule will find it, even if it's not on any search path
1442 mod <- addHomeModuleToFinder hsc_env mod_name location
1444 src_timestamp <- case maybe_buf of
1445 Just (_,t) -> return t
1446 Nothing -> getModificationTime file
1447 -- getMofificationTime may fail
1449 obj_timestamp <- modificationTimeIfExists (ml_obj_file location)
1451 return (ModSummary { ms_mod = mod, ms_hsc_src = HsSrcFile,
1452 ms_location = location,
1453 ms_hspp_file = hspp_fn,
1454 ms_hspp_opts = dflags',
1455 ms_hspp_buf = Just buf,
1456 ms_srcimps = srcimps, ms_imps = the_imps,
1457 ms_hs_date = src_timestamp,
1458 ms_obj_date = obj_timestamp })
1460 findSummaryBySourceFile :: [ModSummary] -> FilePath -> Maybe ModSummary
1461 findSummaryBySourceFile summaries file
1462 = case [ ms | ms <- summaries, HsSrcFile <- [ms_hsc_src ms],
1463 expectJust "findSummaryBySourceFile" (ml_hs_file (ms_location ms)) == file ] of
1467 -- Summarise a module, and pick up source and timestamp.
1470 -> NodeMap ModSummary -- Map of old summaries
1471 -> IsBootInterface -- True <=> a {-# SOURCE #-} import
1472 -> Located ModuleName -- Imported module to be summarised
1473 -> Maybe (StringBuffer, ClockTime)
1474 -> [ModuleName] -- Modules to exclude
1475 -> IO (Maybe ModSummary) -- Its new summary
1477 summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) maybe_buf excl_mods
1478 | wanted_mod `elem` excl_mods
1481 | Just old_summary <- lookupFM old_summary_map (wanted_mod, hsc_src)
1482 = do -- Find its new timestamp; all the
1483 -- ModSummaries in the old map have valid ml_hs_files
1484 let location = ms_location old_summary
1485 src_fn = expectJust "summariseModule" (ml_hs_file location)
1487 -- check the modification time on the source file, and
1488 -- return the cached summary if it hasn't changed. If the
1489 -- file has disappeared, we need to call the Finder again.
1491 Just (_,t) -> check_timestamp old_summary location src_fn t
1493 m <- System.IO.Error.try (getModificationTime src_fn)
1495 Right t -> check_timestamp old_summary location src_fn t
1496 Left e | isDoesNotExistError e -> find_it
1497 | otherwise -> ioError e
1499 | otherwise = find_it
1501 dflags = hsc_dflags hsc_env
1503 hsc_src = if is_boot then HsBootFile else HsSrcFile
1505 check_timestamp old_summary location src_fn src_timestamp
1506 | ms_hs_date old_summary == src_timestamp = do
1507 -- update the object-file timestamp
1508 obj_timestamp <- getObjTimestamp location is_boot
1509 return (Just old_summary{ ms_obj_date = obj_timestamp })
1511 -- source changed: re-summarise.
1512 new_summary location (ms_mod old_summary) src_fn src_timestamp
1515 -- Don't use the Finder's cache this time. If the module was
1516 -- previously a package module, it may have now appeared on the
1517 -- search path, so we want to consider it to be a home module. If
1518 -- the module was previously a home module, it may have moved.
1519 uncacheModule hsc_env wanted_mod
1520 found <- findImportedModule hsc_env wanted_mod Nothing
1523 | isJust (ml_hs_file location) ->
1525 just_found location mod
1527 -- Drop external-pkg
1528 ASSERT(modulePackageId mod /= thisPackage dflags)
1532 err -> noModError dflags loc wanted_mod err
1535 just_found location mod = do
1536 -- Adjust location to point to the hs-boot source file,
1537 -- hi file, object file, when is_boot says so
1538 let location' | is_boot = addBootSuffixLocn location
1539 | otherwise = location
1540 src_fn = expectJust "summarise2" (ml_hs_file location')
1542 -- Check that it exists
1543 -- It might have been deleted since the Finder last found it
1544 maybe_t <- modificationTimeIfExists src_fn
1546 Nothing -> noHsFileErr loc src_fn
1547 Just t -> new_summary location' mod src_fn t
1550 new_summary location mod src_fn src_timestamp
1552 -- Preprocess the source file and get its imports
1553 -- The dflags' contains the OPTIONS pragmas
1554 (dflags', hspp_fn, buf) <- preprocessFile dflags src_fn Nothing maybe_buf
1555 (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn
1557 when (mod_name /= wanted_mod) $
1558 throwDyn $ mkPlainErrMsg mod_loc $
1559 text "file name does not match module name"
1560 <+> quotes (ppr mod_name)
1562 -- Find the object timestamp, and return the summary
1563 obj_timestamp <- getObjTimestamp location is_boot
1565 return (Just ( ModSummary { ms_mod = mod,
1566 ms_hsc_src = hsc_src,
1567 ms_location = location,
1568 ms_hspp_file = hspp_fn,
1569 ms_hspp_opts = dflags',
1570 ms_hspp_buf = Just buf,
1571 ms_srcimps = srcimps,
1573 ms_hs_date = src_timestamp,
1574 ms_obj_date = obj_timestamp }))
1577 getObjTimestamp location is_boot
1578 = if is_boot then return Nothing
1579 else modificationTimeIfExists (ml_obj_file location)
1582 preprocessFile :: DynFlags -> FilePath -> Maybe Phase -> Maybe (StringBuffer,ClockTime)
1583 -> IO (DynFlags, FilePath, StringBuffer)
1584 preprocessFile dflags src_fn mb_phase Nothing
1586 (dflags', hspp_fn) <- preprocess dflags (src_fn, mb_phase)
1587 buf <- hGetStringBuffer hspp_fn
1588 return (dflags', hspp_fn, buf)
1590 preprocessFile dflags src_fn mb_phase (Just (buf, time))
1592 -- case we bypass the preprocessing stage?
1594 local_opts = getOptions buf src_fn
1596 (dflags', errs) <- parseDynamicFlags dflags (map unLoc local_opts)
1600 | Just (Unlit _) <- mb_phase = True
1601 | Nothing <- mb_phase, Unlit _ <- startPhase src_fn = True
1602 -- note: local_opts is only required if there's no Unlit phase
1603 | dopt Opt_Cpp dflags' = True
1604 | dopt Opt_Pp dflags' = True
1607 when needs_preprocessing $
1608 ghcError (ProgramError "buffer needs preprocesing; interactive check disabled")
1610 return (dflags', src_fn, buf)
1613 -----------------------------------------------------------------------------
1615 -----------------------------------------------------------------------------
1617 noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> IO ab
1618 -- ToDo: we don't have a proper line number for this error
1619 noModError dflags loc wanted_mod err
1620 = throwDyn $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err
1622 noHsFileErr loc path
1623 = throwDyn $ mkPlainErrMsg loc $ text "Can't find" <+> text path
1626 = throwDyn $ mkPlainErrMsg noSrcSpan $
1627 text "module" <+> quotes (ppr mod) <+> text "is a package module"
1629 multiRootsErr :: [ModSummary] -> IO ()
1630 multiRootsErr summs@(summ1:_)
1631 = throwDyn $ mkPlainErrMsg noSrcSpan $
1632 text "module" <+> quotes (ppr mod) <+>
1633 text "is defined in multiple files:" <+>
1634 sep (map text files)
1637 files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs
1639 cyclicModuleErr :: [ModSummary] -> SDoc
1641 = hang (ptext SLIT("Module imports form a cycle for modules:"))
1642 2 (vcat (map show_one ms))
1644 show_one ms = sep [ show_mod (ms_hsc_src ms) (ms_mod ms),
1645 nest 2 $ ptext SLIT("imports:") <+>
1646 (pp_imps HsBootFile (ms_srcimps ms)
1647 $$ pp_imps HsSrcFile (ms_imps ms))]
1648 show_mod hsc_src mod = ppr mod <> text (hscSourceString hsc_src)
1649 pp_imps src mods = fsep (map (show_mod src) mods)
1652 -- | Inform GHC that the working directory has changed. GHC will flush
1653 -- its cache of module locations, since it may no longer be valid.
1654 -- Note: if you change the working directory, you should also unload
1655 -- the current program (set targets to empty, followed by load).
1656 workingDirectoryChanged :: Session -> IO ()
1657 workingDirectoryChanged s = withSession s $ flushFinderCaches
1659 -- -----------------------------------------------------------------------------
1660 -- inspecting the session
1662 -- | Get the module dependency graph.
1663 getModuleGraph :: Session -> IO ModuleGraph -- ToDo: DiGraph ModSummary
1664 getModuleGraph s = withSession s (return . hsc_mod_graph)
1666 isLoaded :: Session -> ModuleName -> IO Bool
1667 isLoaded s m = withSession s $ \hsc_env ->
1668 return $! isJust (lookupUFM (hsc_HPT hsc_env) m)
1670 getBindings :: Session -> IO [TyThing]
1671 getBindings s = withSession s (return . nameEnvElts . ic_type_env . hsc_IC)
1673 getPrintUnqual :: Session -> IO PrintUnqualified
1674 getPrintUnqual s = withSession s (return . icPrintUnqual . hsc_IC)
1676 -- | Container for information about a 'Module'.
1677 data ModuleInfo = ModuleInfo {
1678 minf_type_env :: TypeEnv,
1679 minf_exports :: NameSet,
1680 minf_rdr_env :: Maybe GlobalRdrEnv, -- Nothing for a compiled/package mod
1681 minf_instances :: [Instance]
1682 -- ToDo: this should really contain the ModIface too
1684 -- We don't want HomeModInfo here, because a ModuleInfo applies
1685 -- to package modules too.
1687 -- | Request information about a loaded 'Module'
1688 getModuleInfo :: Session -> Module -> IO (Maybe ModuleInfo)
1689 getModuleInfo s mdl = withSession s $ \hsc_env -> do
1690 let mg = hsc_mod_graph hsc_env
1691 if mdl `elem` map ms_mod mg
1692 then getHomeModuleInfo hsc_env (moduleName mdl)
1694 {- if isHomeModule (hsc_dflags hsc_env) mdl
1696 else -} getPackageModuleInfo hsc_env mdl
1697 -- getPackageModuleInfo will attempt to find the interface, so
1698 -- we don't want to call it for a home module, just in case there
1699 -- was a problem loading the module and the interface doesn't
1700 -- exist... hence the isHomeModule test here. (ToDo: reinstate)
1702 getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
1703 getPackageModuleInfo hsc_env mdl = do
1705 (_msgs, mb_names) <- getModuleExports hsc_env mdl
1707 Nothing -> return Nothing
1709 eps <- readIORef (hsc_EPS hsc_env)
1712 n_list = nameSetToList names
1713 tys = [ ty | name <- n_list,
1714 Just ty <- [lookupTypeEnv pte name] ]
1716 return (Just (ModuleInfo {
1717 minf_type_env = mkTypeEnv tys,
1718 minf_exports = names,
1719 minf_rdr_env = Just $! nameSetToGlobalRdrEnv names (moduleName mdl),
1720 minf_instances = error "getModuleInfo: instances for package module unimplemented"
1723 -- bogusly different for non-GHCI (ToDo)
1727 getHomeModuleInfo hsc_env mdl =
1728 case lookupUFM (hsc_HPT hsc_env) mdl of
1729 Nothing -> return Nothing
1731 let details = hm_details hmi
1732 return (Just (ModuleInfo {
1733 minf_type_env = md_types details,
1734 minf_exports = md_exports details,
1735 minf_rdr_env = mi_globals $! hm_iface hmi,
1736 minf_instances = md_insts details
1739 -- | The list of top-level entities defined in a module
1740 modInfoTyThings :: ModuleInfo -> [TyThing]
1741 modInfoTyThings minf = typeEnvElts (minf_type_env minf)
1743 modInfoTopLevelScope :: ModuleInfo -> Maybe [Name]
1744 modInfoTopLevelScope minf
1745 = fmap (map gre_name . globalRdrEnvElts) (minf_rdr_env minf)
1747 modInfoExports :: ModuleInfo -> [Name]
1748 modInfoExports minf = nameSetToList $! minf_exports minf
1750 -- | Returns the instances defined by the specified module.
1751 -- Warning: currently unimplemented for package modules.
1752 modInfoInstances :: ModuleInfo -> [Instance]
1753 modInfoInstances = minf_instances
1755 modInfoIsExportedName :: ModuleInfo -> Name -> Bool
1756 modInfoIsExportedName minf name = elemNameSet name (minf_exports minf)
1758 modInfoPrintUnqualified :: ModuleInfo -> Maybe PrintUnqualified
1759 modInfoPrintUnqualified minf = fmap mkPrintUnqualified (minf_rdr_env minf)
1761 modInfoLookupName :: Session -> ModuleInfo -> Name -> IO (Maybe TyThing)
1762 modInfoLookupName s minf name = withSession s $ \hsc_env -> do
1763 case lookupTypeEnv (minf_type_env minf) name of
1764 Just tyThing -> return (Just tyThing)
1766 eps <- readIORef (hsc_EPS hsc_env)
1767 return $! lookupType (hsc_dflags hsc_env)
1768 (hsc_HPT hsc_env) (eps_PTE eps) name
1770 isDictonaryId :: Id -> Bool
1772 = case tcSplitSigmaTy (idType id) of { (tvs, theta, tau) -> isDictTy tau }
1774 -- | Looks up a global name: that is, any top-level name in any
1775 -- visible module. Unlike 'lookupName', lookupGlobalName does not use
1776 -- the interactive context, and therefore does not require a preceding
1778 lookupGlobalName :: Session -> Name -> IO (Maybe TyThing)
1779 lookupGlobalName s name = withSession s $ \hsc_env -> do
1780 eps <- readIORef (hsc_EPS hsc_env)
1781 return $! lookupType (hsc_dflags hsc_env)
1782 (hsc_HPT hsc_env) (eps_PTE eps) name
1784 -- -----------------------------------------------------------------------------
1785 -- Misc exported utils
1787 dataConType :: DataCon -> Type
1788 dataConType dc = idType (dataConWrapId dc)
1790 -- | print a 'NamedThing', adding parentheses if the name is an operator.
1791 pprParenSymName :: NamedThing a => a -> SDoc
1792 pprParenSymName a = parenSymOcc (getOccName a) (ppr (getName a))
1794 -- ----------------------------------------------------------------------------
1799 -- - Data and Typeable instances for HsSyn.
1801 -- ToDo: check for small transformations that happen to the syntax in
1802 -- the typechecker (eg. -e ==> negate e, perhaps for fromIntegral)
1804 -- ToDo: maybe use TH syntax instead of IfaceSyn? There's already a way
1805 -- to get from TyCons, Ids etc. to TH syntax (reify).
1807 -- :browse will use either lm_toplev or inspect lm_interface, depending
1808 -- on whether the module is interpreted or not.
1810 -- This is for reconstructing refactored source code
1811 -- Calls the lexer repeatedly.
1812 -- ToDo: add comment tokens to token stream
1813 getTokenStream :: Session -> Module -> IO [Located Token]
1816 -- -----------------------------------------------------------------------------
1817 -- Interactive evaluation
1819 -- | Takes a 'ModuleName' and possibly a 'PackageId', and consults the
1820 -- filesystem and package database to find the corresponding 'Module',
1821 -- using the algorithm that is used for an @import@ declaration.
1822 findModule :: Session -> ModuleName -> Maybe PackageId -> IO Module
1823 findModule s mod_name maybe_pkg = withSession s $ \hsc_env ->
1824 findModule' hsc_env mod_name maybe_pkg
1826 findModule' hsc_env mod_name maybe_pkg =
1828 dflags = hsc_dflags hsc_env
1829 hpt = hsc_HPT hsc_env
1830 this_pkg = thisPackage dflags
1832 case lookupUFM hpt mod_name of
1833 Just mod_info -> return (mi_module (hm_iface mod_info))
1834 _not_a_home_module -> do
1835 res <- findImportedModule hsc_env mod_name Nothing
1837 Found _ m | modulePackageId m /= this_pkg -> return m
1838 | otherwise -> throwDyn (CmdLineError (showSDoc $
1839 text "module" <+> pprModule m <+>
1840 text "is not loaded"))
1841 err -> let msg = cannotFindModule dflags mod_name err in
1842 throwDyn (CmdLineError (showSDoc msg))
1846 -- | Set the interactive evaluation context.
1848 -- Setting the context doesn't throw away any bindings; the bindings
1849 -- we've built up in the InteractiveContext simply move to the new
1850 -- module. They always shadow anything in scope in the current context.
1851 setContext :: Session
1852 -> [Module] -- entire top level scope of these modules
1853 -> [Module] -- exports only of these modules
1855 setContext (Session ref) toplev_mods export_mods = do
1856 hsc_env <- readIORef ref
1857 let old_ic = hsc_IC hsc_env
1858 hpt = hsc_HPT hsc_env
1860 export_env <- mkExportEnv hsc_env export_mods
1861 toplev_envs <- mapM (mkTopLevEnv hpt) toplev_mods
1862 let all_env = foldr plusGlobalRdrEnv export_env toplev_envs
1863 writeIORef ref hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplev_mods,
1864 ic_exports = export_mods,
1865 ic_rn_gbl_env = all_env }}
1868 -- Make a GlobalRdrEnv based on the exports of the modules only.
1869 mkExportEnv :: HscEnv -> [Module] -> IO GlobalRdrEnv
1870 mkExportEnv hsc_env mods = do
1871 stuff <- mapM (getModuleExports hsc_env) mods
1873 (_msgs, mb_name_sets) = unzip stuff
1874 gres = [ nameSetToGlobalRdrEnv name_set (moduleName mod)
1875 | (Just name_set, mod) <- zip mb_name_sets mods ]
1877 return $! foldr plusGlobalRdrEnv emptyGlobalRdrEnv gres
1879 nameSetToGlobalRdrEnv :: NameSet -> ModuleName -> GlobalRdrEnv
1880 nameSetToGlobalRdrEnv names mod =
1881 mkGlobalRdrEnv [ GRE { gre_name = name, gre_prov = vanillaProv mod }
1882 | name <- nameSetToList names ]
1884 vanillaProv :: ModuleName -> Provenance
1885 -- We're building a GlobalRdrEnv as if the user imported
1886 -- all the specified modules into the global interactive module
1887 vanillaProv mod_name = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}]
1889 decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name,
1891 is_dloc = srcLocSpan interactiveSrcLoc }
1893 mkTopLevEnv :: HomePackageTable -> Module -> IO GlobalRdrEnv
1894 mkTopLevEnv hpt modl
1895 = case lookupUFM hpt (moduleName modl) of
1896 Nothing -> throwDyn (ProgramError ("mkTopLevEnv: not a home module " ++
1897 showSDoc (ppr modl)))
1899 case mi_globals (hm_iface details) of
1901 throwDyn (ProgramError ("mkTopLevEnv: not interpreted "
1902 ++ showSDoc (ppr modl)))
1903 Just env -> return env
1905 -- | Get the interactive evaluation context, consisting of a pair of the
1906 -- set of modules from which we take the full top-level scope, and the set
1907 -- of modules from which we take just the exports respectively.
1908 getContext :: Session -> IO ([Module],[Module])
1909 getContext s = withSession s (\HscEnv{ hsc_IC=ic } ->
1910 return (ic_toplev_scope ic, ic_exports ic))
1912 -- | Returns 'True' if the specified module is interpreted, and hence has
1913 -- its full top-level scope available.
1914 moduleIsInterpreted :: Session -> Module -> IO Bool
1915 moduleIsInterpreted s modl = withSession s $ \h ->
1916 if modulePackageId modl /= thisPackage (hsc_dflags h)
1918 else case lookupUFM (hsc_HPT h) (moduleName modl) of
1919 Just details -> return (isJust (mi_globals (hm_iface details)))
1920 _not_a_home_module -> return False
1922 -- | Looks up an identifier in the current interactive context (for :info)
1923 getInfo :: Session -> Name -> IO (Maybe (TyThing,Fixity,[Instance]))
1924 getInfo s name = withSession s $ \hsc_env -> tcRnGetInfo hsc_env name
1926 -- | Returns all names in scope in the current interactive context
1927 getNamesInScope :: Session -> IO [Name]
1928 getNamesInScope s = withSession s $ \hsc_env -> do
1929 return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env))))
1931 getRdrNamesInScope :: Session -> IO [RdrName]
1932 getRdrNamesInScope s = withSession s $ \hsc_env -> do
1933 let env = ic_rn_gbl_env (hsc_IC hsc_env)
1934 return (concat (map greToRdrNames (globalRdrEnvElts env)))
1936 -- ToDo: move to RdrName
1937 greToRdrNames :: GlobalRdrElt -> [RdrName]
1938 greToRdrNames GRE{ gre_name = name, gre_prov = prov }
1940 LocalDef -> [unqual]
1941 Imported specs -> concat (map do_spec (map is_decl specs))
1943 occ = nameOccName name
1946 | is_qual decl_spec = [qual]
1947 | otherwise = [unqual,qual]
1948 where qual = Qual (is_as decl_spec) occ
1950 -- | Parses a string as an identifier, and returns the list of 'Name's that
1951 -- the identifier can refer to in the current interactive context.
1952 parseName :: Session -> String -> IO [Name]
1953 parseName s str = withSession s $ \hsc_env -> do
1954 maybe_rdr_name <- hscParseIdentifier (hsc_dflags hsc_env) str
1955 case maybe_rdr_name of
1956 Nothing -> return []
1957 Just (L _ rdr_name) -> do
1958 mb_names <- tcRnLookupRdrName hsc_env rdr_name
1960 Nothing -> return []
1961 Just ns -> return ns
1962 -- ToDo: should return error messages
1964 -- | Returns the 'TyThing' for a 'Name'. The 'Name' may refer to any
1965 -- entity known to GHC, including 'Name's defined using 'runStmt'.
1966 lookupName :: Session -> Name -> IO (Maybe TyThing)
1967 lookupName s name = withSession s $ \hsc_env -> tcRnLookupName hsc_env name
1969 -- -----------------------------------------------------------------------------
1970 -- Getting the type of an expression
1972 -- | Get the type of an expression
1973 exprType :: Session -> String -> IO (Maybe Type)
1974 exprType s expr = withSession s $ \hsc_env -> do
1975 maybe_stuff <- hscTcExpr hsc_env expr
1977 Nothing -> return Nothing
1978 Just ty -> return (Just tidy_ty)
1980 tidy_ty = tidyType emptyTidyEnv ty
1982 -- -----------------------------------------------------------------------------
1983 -- Getting the kind of a type
1985 -- | Get the kind of a type
1986 typeKind :: Session -> String -> IO (Maybe Kind)
1987 typeKind s str = withSession s $ \hsc_env -> do
1988 maybe_stuff <- hscKcType hsc_env str
1990 Nothing -> return Nothing
1991 Just kind -> return (Just kind)
1993 -----------------------------------------------------------------------------
1994 -- cmCompileExpr: compile an expression and deliver an HValue
1996 compileExpr :: Session -> String -> IO (Maybe HValue)
1997 compileExpr s expr = withSession s $ \hsc_env -> do
1998 maybe_stuff <- hscStmt hsc_env ("let __cmCompileExpr = "++expr)
2000 Nothing -> return Nothing
2001 Just (new_ic, names, hval) -> do
2003 hvals <- (unsafeCoerce# hval) :: IO [HValue]
2005 case (names,hvals) of
2006 ([n],[hv]) -> return (Just hv)
2007 _ -> panic "compileExpr"
2009 -- -----------------------------------------------------------------------------
2010 -- Compile an expression into a dynamic
2012 dynCompileExpr :: Session -> String -> IO (Maybe Dynamic)
2013 dynCompileExpr ses expr = do
2014 (full,exports) <- getContext ses
2015 setContext ses full $
2017 (stringToPackageId "base") (mkModuleName "Data.Dynamic")
2019 let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")"
2020 res <- withSession ses (flip hscStmt stmt)
2021 setContext ses full exports
2023 Nothing -> return Nothing
2024 Just (_, names, hvals) -> do
2025 vals <- (unsafeCoerce# hvals :: IO [Dynamic])
2026 case (names,vals) of
2027 (_:[], v:[]) -> return (Just v)
2028 _ -> panic "dynCompileExpr"
2030 -- -----------------------------------------------------------------------------
2031 -- running a statement interactively
2034 = RunOk [Name] -- ^ names bound by this evaluation
2035 | RunFailed -- ^ statement failed compilation
2036 | RunException Exception -- ^ statement raised an exception
2038 -- | Run a statement in the current interactive context. Statemenet
2039 -- may bind multple values.
2040 runStmt :: Session -> String -> IO RunResult
2041 runStmt (Session ref) expr
2043 hsc_env <- readIORef ref
2045 -- Turn off -fwarn-unused-bindings when running a statement, to hide
2046 -- warnings about the implicit bindings we introduce.
2047 let dflags' = dopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds
2048 hsc_env' = hsc_env{ hsc_dflags = dflags' }
2050 maybe_stuff <- hscStmt hsc_env' expr
2053 Nothing -> return RunFailed
2054 Just (new_hsc_env, names, hval) -> do
2056 let thing_to_run = unsafeCoerce# hval :: IO [HValue]
2057 either_hvals <- sandboxIO thing_to_run
2059 case either_hvals of
2061 -- on error, keep the *old* interactive context,
2062 -- so that 'it' is not bound to something
2063 -- that doesn't exist.
2064 return (RunException e)
2067 -- Get the newly bound things, and bind them.
2068 -- Don't need to delete any shadowed bindings;
2069 -- the new ones override the old ones.
2070 extendLinkEnv (zip names hvals)
2072 writeIORef ref new_hsc_env
2073 return (RunOk names)
2075 -- When running a computation, we redirect ^C exceptions to the running
2076 -- thread. ToDo: we might want a way to continue even if the target
2077 -- thread doesn't die when it receives the exception... "this thread
2078 -- is not responding".
2079 sandboxIO :: IO a -> IO (Either Exception a)
2080 sandboxIO thing = do
2082 ts <- takeMVar interruptTargetThread
2083 child <- forkIO (do res <- Exception.try thing; putMVar m res)
2084 putMVar interruptTargetThread (child:ts)
2085 takeMVar m `finally` modifyMVar_ interruptTargetThread (return.tail)
2088 -- This version of sandboxIO runs the expression in a completely new
2089 -- RTS main thread. It is disabled for now because ^C exceptions
2090 -- won't be delivered to the new thread, instead they'll be delivered
2091 -- to the (blocked) GHCi main thread.
2093 -- SLPJ: when re-enabling this, reflect a wrong-stat error as an exception
2095 sandboxIO :: IO a -> IO (Either Int (Either Exception a))
2096 sandboxIO thing = do
2097 st_thing <- newStablePtr (Exception.try thing)
2098 alloca $ \ p_st_result -> do
2099 stat <- rts_evalStableIO st_thing p_st_result
2100 freeStablePtr st_thing
2102 then do st_result <- peek p_st_result
2103 result <- deRefStablePtr st_result
2104 freeStablePtr st_result
2105 return (Right result)
2107 return (Left (fromIntegral stat))
2109 foreign import "rts_evalStableIO" {- safe -}
2110 rts_evalStableIO :: StablePtr (IO a) -> Ptr (StablePtr a) -> IO CInt
2111 -- more informative than the C type!
2114 -----------------------------------------------------------------------------
2115 -- show a module and it's source/object filenames
2117 showModule :: Session -> ModSummary -> IO String
2118 showModule s mod_summary = withSession s $ \hsc_env -> do
2119 case lookupUFM (hsc_HPT hsc_env) (ms_mod_name mod_summary) of
2120 Nothing -> panic "missing linkable"
2121 Just mod_info -> return (showModMsg (hscTarget (hsc_dflags hsc_env)) (not obj_linkable) mod_summary)
2123 obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info))