ghc/compiler/main/GHC.hs

   1 -- -----------------------------------------------------------------------------
   2 --
   3 -- (c) The University of Glasgow, 2005
   4 --
   5 -- The GHC API
   6 --
   7 -- -----------------------------------------------------------------------------
   8
   9 module GHC (
  10         -- * Initialisation
  11         Session,
  12         defaultErrorHandler,
  13         defaultCleanupHandler,
  14         init,
  15         newSession,
  16
  17         -- * Flags and settings
  18         DynFlags(..), DynFlag(..), GhcMode(..), HscTarget(..), dopt,
  19         parseDynamicFlags,
  20         initPackages,
  21         getSessionDynFlags,
  22         setSessionDynFlags,
  23         setMsgHandler,
  24
  25         -- * Targets
  26         Target(..), TargetId(..), Phase,
  27         setTargets,
  28         getTargets,
  29         addTarget,
  30         removeTarget,
  31         guessTarget,
  32
  33         -- * Loading\/compiling the program
  34         depanal,
  35         load, LoadHowMuch(..), SuccessFlag(..), -- also does depanal
  36         loadMsgs,
  37         workingDirectoryChanged,
  38         checkModule, CheckedModule(..),
  39         TypecheckedSource, ParsedSource, RenamedSource,
  40
  41         -- * Inspecting the module structure of the program
  42         ModuleGraph, ModSummary(..),
  43         getModuleGraph,
  44         isLoaded,
  45         topSortModuleGraph,
  46
  47         -- * Inspecting modules
  48         ModuleInfo,
  49         getModuleInfo,
  50         modInfoTyThings,
  51         modInfoTopLevelScope,
  52         modInfoPrintUnqualified,
  53         modInfoExports,
  54         modInfoIsExportedName,
  55         modInfoLookupName,
  56         lookupGlobalName,
  57
  58         -- * Interactive evaluation
  59         getBindings, getPrintUnqual,
  60 #ifdef GHCI
  61         setContext, getContext,
  62         getNamesInScope,
  63         moduleIsInterpreted,
  64         getInfo, GetInfoResult,
  65         exprType,
  66         typeKind,
  67         parseName,
  68         RunResult(..),
  69         runStmt,
  70         browseModule,
  71         showModule,
  72         compileExpr, HValue,
  73         lookupName,
  74 #endif
  75
  76         -- * Abstract syntax elements
  77
  78         -- ** Modules
  79         Module, mkModule, pprModule,
  80
  81         -- ** Names
  82         Name, nameModule,
  83
  84         -- ** Identifiers
  85         Id, idType,
  86         isImplicitId, isDeadBinder,
  87         isSpecPragmaId, isExportedId, isLocalId, isGlobalId,
  88         isRecordSelector,
  89         isPrimOpId, isFCallId,
  90         isDataConWorkId, idDataCon,
  91         isBottomingId, isDictonaryId,
  92
  93         -- ** Type constructors
  94         TyCon,
  95         isClassTyCon, isSynTyCon, isNewTyCon,
  96
  97         -- ** Data constructors
  98         DataCon,
  99
 100         -- ** Classes
 101         Class,
 102         classSCTheta, classTvsFds,
 103
 104         -- ** Types and Kinds
 105         Type, dropForAlls,
 106         Kind,
 107
 108         -- ** Entities
 109         TyThing(..),
 110
 111         -- ** Syntax
 112         module HsSyn, -- ToDo: remove extraneous bits
 113
 114         -- * Exceptions
 115         GhcException(..), showGhcException,
 116
 117         -- * Miscellaneous
 118         sessionHscEnv,
 119         cyclicModuleErr,
 120   ) where
 121
 122 {-
 123  ToDo:
 124
 125   * inline bits of HscMain here to simplify layering: hscGetInfo,
 126     hscTcExpr, hscStmt.
 127   * we need to expose DynFlags, so should parseDynamicFlags really be
 128     part of this interface?
 129   * what StaticFlags should we expose, if any?
 130 -}
 131
 132 #include "HsVersions.h"
 133
 134 #ifdef GHCI
 135 import qualified Linker
 136 import Linker           ( HValue, extendLinkEnv )
 137 import NameEnv          ( lookupNameEnv )
 138 import TcRnDriver       ( getModuleContents, tcRnLookupRdrName,
 139                           getModuleExports )
 140 import RdrName          ( plusGlobalRdrEnv, Provenance(..), ImportSpec(..),
 141                           emptyGlobalRdrEnv, mkGlobalRdrEnv )
 142 import HscMain          ( hscGetInfo, GetInfoResult, hscParseIdentifier,
 143                           hscStmt, hscTcExpr, hscKcType )
 144 import Type             ( tidyType )
 145 import VarEnv           ( emptyTidyEnv )
 146 import GHC.Exts         ( unsafeCoerce# )
 147 import IfaceSyn         ( IfaceDecl )
 148 import Name             ( getName, nameModule_maybe )
 149 import SrcLoc           ( mkSrcLoc, srcLocSpan, interactiveSrcLoc )
 150 import Bag              ( unitBag, emptyBag )
 151 #endif
 152
 153 import Packages         ( initPackages )
 154 import NameSet          ( NameSet, nameSetToList, elemNameSet )
 155 import RdrName          ( GlobalRdrEnv, GlobalRdrElt(..), RdrName, gre_name,
 156                           globalRdrEnvElts )
 157 import HsSyn
 158 import Type             ( Kind, Type, dropForAlls )
 159 import Id               ( Id, idType, isImplicitId, isDeadBinder,
 160                           isSpecPragmaId, isExportedId, isLocalId, isGlobalId,
 161                           isRecordSelector,
 162                           isPrimOpId, isFCallId,
 163                           isDataConWorkId, idDataCon,
 164                           isBottomingId )
 165 import TyCon            ( TyCon, isClassTyCon, isSynTyCon, isNewTyCon )
 166 import Class            ( Class, classSCTheta, classTvsFds )
 167 import DataCon          ( DataCon )
 168 import Name             ( Name, nameModule )
 169 import NameEnv          ( nameEnvElts )
 170 import SrcLoc           ( Located(..) )
 171 import DriverPipeline
 172 import DriverPhases     ( Phase(..), isHaskellSrcFilename, startPhase )
 173 import GetImports       ( getImports )
 174 import Packages         ( isHomePackage )
 175 import Finder
 176 import HscMain          ( newHscEnv, hscFileCheck, HscResult(..) )
 177 import HscTypes
 178 import DynFlags
 179 import StaticFlags
 180 import SysTools         ( initSysTools, cleanTempFiles )
 181 import Module
 182 import FiniteMap
 183 import Panic
 184 import Digraph
 185 import ErrUtils         ( showPass, Messages, putMsg, debugTraceMsg )
 186 import qualified ErrUtils
 187 import Util
 188 import StringBuffer     ( StringBuffer, hGetStringBuffer )
 189 import Outputable
 190 import SysTools         ( cleanTempFilesExcept )
 191 import BasicTypes       ( SuccessFlag(..), succeeded, failed )
 192 import Maybes           ( orElse, expectJust, mapCatMaybes )
 193 import TcType           ( tcSplitSigmaTy, isDictTy )
 194 import FastString       ( mkFastString )
 195
 196 import Directory        ( getModificationTime, doesFileExist )
 197 import Maybe            ( isJust, isNothing, fromJust, fromMaybe, catMaybes )
 198 import Maybes           ( expectJust )
 199 import List             ( partition, nub )
 200 import qualified List
 201 import Monad            ( unless, when, foldM )
 202 import System           ( exitWith, ExitCode(..) )
 203 import Time             ( ClockTime )
 204 import EXCEPTION as Exception hiding (handle)
 205 import DATA_IOREF
 206 import IO
 207 import Prelude hiding (init)
 208
 209 -- -----------------------------------------------------------------------------
 210 -- Exception handlers
 211
 212 -- | Install some default exception handlers and run the inner computation.
 213 -- Unless you want to handle exceptions yourself, you should wrap this around
 214 -- the top level of your program.  The default handlers output the error
 215 -- message(s) to stderr and exit cleanly.
 216 defaultErrorHandler :: IO a -> IO a
 217 defaultErrorHandler inner =
 218   -- top-level exception handler: any unrecognised exception is a compiler bug.
 219   handle (\exception -> do
 220            hFlush stdout
 221            case exception of
 222                 -- an IO exception probably isn't our fault, so don't panic
 223                 IOException _ ->  putMsg (show exception)
 224                 AsyncException StackOverflow ->
 225                         putMsg "stack overflow: use +RTS -K<size> to increase it"
 226                 _other ->  putMsg (show (Panic (show exception)))
 227            exitWith (ExitFailure 1)
 228          ) $
 229
 230   -- all error messages are propagated as exceptions
 231   handleDyn (\dyn -> do
 232                 hFlush stdout
 233                 case dyn of
 234                      PhaseFailed _ code -> exitWith code
 235                      Interrupted -> exitWith (ExitFailure 1)
 236                      _ -> do putMsg (show (dyn :: GhcException))
 237                              exitWith (ExitFailure 1)
 238             ) $
 239   inner
 240
 241 -- | Install a default cleanup handler to remove temporary files
 242 -- deposited by a GHC run.  This is seperate from
 243 -- 'defaultErrorHandler', because you might want to override the error
 244 -- handling, but still get the ordinary cleanup behaviour.
 245 defaultCleanupHandler :: DynFlags -> IO a -> IO a
 246 defaultCleanupHandler dflags inner =
 247    -- make sure we clean up after ourselves
 248    later (unless (dopt Opt_KeepTmpFiles dflags) $
 249             cleanTempFiles dflags)
 250         -- exceptions will be blocked while we clean the temporary files,
 251         -- so there shouldn't be any difficulty if we receive further
 252         -- signals.
 253    inner
 254
 255
 256 -- | Initialises GHC.  This must be done /once/ only.  Takes the
 257 -- command-line arguments.  All command-line arguments which aren't
 258 -- understood by GHC will be returned.
 259
 260 init :: [String] -> IO [String]
 261 init args = do
 262    -- catch ^C
 263    installSignalHandlers
 264
 265    -- Grab the -B option if there is one
 266    let (minusB_args, argv1) = partition (prefixMatch "-B") args
 267    dflags0 <- initSysTools minusB_args defaultDynFlags
 268    writeIORef v_initDynFlags dflags0
 269
 270    -- Parse the static flags
 271    argv2 <- parseStaticFlags argv1
 272    return argv2
 273
 274 GLOBAL_VAR(v_initDynFlags, error "initDynFlags", DynFlags)
 275         -- stores the DynFlags between the call to init and subsequent
 276         -- calls to newSession.
 277
 278 -- | Starts a new session.  A session consists of a set of loaded
 279 -- modules, a set of options (DynFlags), and an interactive context.
 280 -- ToDo: GhcMode should say "keep typechecked code" and\/or "keep renamed
 281 -- code".
 282 newSession :: GhcMode -> IO Session
 283 newSession mode = do
 284   dflags0 <- readIORef v_initDynFlags
 285   dflags <- initDynFlags dflags0
 286   env <- newHscEnv dflags{ ghcMode=mode }
 287   ref <- newIORef env
 288   return (Session ref)
 289
 290 -- tmp: this breaks the abstraction, but required because DriverMkDepend
 291 -- needs to call the Finder.  ToDo: untangle this.
 292 sessionHscEnv :: Session -> IO HscEnv
 293 sessionHscEnv (Session ref) = readIORef ref
 294
 295 withSession :: Session -> (HscEnv -> IO a) -> IO a
 296 withSession (Session ref) f = do h <- readIORef ref; f h
 297
 298 modifySession :: Session -> (HscEnv -> HscEnv) -> IO ()
 299 modifySession (Session ref) f = do h <- readIORef ref; writeIORef ref $! f h
 300
 301 -- -----------------------------------------------------------------------------
 302 -- Flags & settings
 303
 304 -- | Grabs the DynFlags from the Session
 305 getSessionDynFlags :: Session -> IO DynFlags
 306 getSessionDynFlags s = withSession s (return . hsc_dflags)
 307
 308 -- | Updates the DynFlags in a Session
 309 setSessionDynFlags :: Session -> DynFlags -> IO ()
 310 setSessionDynFlags s dflags = modifySession s (\h -> h{ hsc_dflags = dflags })
 311
 312 -- | Messages during compilation (eg. warnings and progress messages)
 313 -- are reported using this callback.  By default, these messages are
 314 -- printed to stderr.
 315 setMsgHandler :: (String -> IO ()) -> IO ()
 316 setMsgHandler = ErrUtils.setMsgHandler
 317
 318 -- -----------------------------------------------------------------------------
 319 -- Targets
 320
 321 -- ToDo: think about relative vs. absolute file paths. And what
 322 -- happens when the current directory changes.
 323
 324 -- | Sets the targets for this session.  Each target may be a module name
 325 -- or a filename.  The targets correspond to the set of root modules for
 326 -- the program\/library.  Unloading the current program is achieved by
 327 -- setting the current set of targets to be empty, followed by load.
 328 setTargets :: Session -> [Target] -> IO ()
 329 setTargets s targets = modifySession s (\h -> h{ hsc_targets = targets })
 330
 331 -- | returns the current set of targets
 332 getTargets :: Session -> IO [Target]
 333 getTargets s = withSession s (return . hsc_targets)
 334
 335 -- | Add another target
 336 addTarget :: Session -> Target -> IO ()
 337 addTarget s target
 338   = modifySession s (\h -> h{ hsc_targets = target : hsc_targets h })
 339
 340 -- | Remove a target
 341 removeTarget :: Session -> TargetId -> IO ()
 342 removeTarget s target_id
 343   = modifySession s (\h -> h{ hsc_targets = filter (hsc_targets h) })
 344   where
 345    filter targets = [ t | t@(Target id _) <- targets, id /= target_id ]
 346
 347 -- Attempts to guess what Target a string refers to.  This function implements
 348 -- the --make/GHCi command-line syntax for filenames:
 349 --
 350 --      - if the string looks like a Haskell source filename, then interpret
 351 --        it as such
 352 --      - if adding a .hs or .lhs suffix yields the name of an existing file,
 353 --        then use that
 354 --      - otherwise interpret the string as a module name
 355 --
 356 guessTarget :: String -> Maybe Phase -> IO Target
 357 guessTarget file (Just phase)
 358    = return (Target (TargetFile file (Just phase)) Nothing)
 359 guessTarget file Nothing
 360    | isHaskellSrcFilename file
 361    = return (Target (TargetFile file Nothing) Nothing)
 362    | otherwise
 363    = do exists <- doesFileExist hs_file
 364         if exists
 365            then return (Target (TargetFile hs_file Nothing) Nothing)
 366            else do
 367         exists <- doesFileExist lhs_file
 368         if exists
 369            then return (Target (TargetFile lhs_file Nothing) Nothing)
 370            else do
 371         return (Target (TargetModule (mkModule file)) Nothing)
 372      where
 373          hs_file = file ++ ".hs"
 374          lhs_file = file ++ ".lhs"
 375
 376 -- -----------------------------------------------------------------------------
 377 -- Loading the program
 378
 379 -- Perform a dependency analysis starting from the current targets
 380 -- and update the session with the new module graph.
 381 depanal :: Session -> [Module] -> IO ()
 382 depanal (Session ref) excluded_mods = do
 383   hsc_env <- readIORef ref
 384   let
 385          dflags  = hsc_dflags hsc_env
 386          gmode   = ghcMode (hsc_dflags hsc_env)
 387          targets = hsc_targets hsc_env
 388          old_graph = hsc_mod_graph hsc_env
 389
 390   showPass dflags "Chasing dependencies"
 391   when (gmode == BatchCompile) $
 392         debugTraceMsg dflags 1 (showSDoc (hcat [
 393                      text "Chasing modules from: ",
 394                         hcat (punctuate comma (map pprTarget targets))]))
 395
 396   graph <- downsweep hsc_env old_graph excluded_mods
 397   writeIORef ref hsc_env{ hsc_mod_graph=graph }
 398
 399 {-
 400 -- | The result of load.
 401 data LoadResult
 402   = LoadOk      Errors  -- ^ all specified targets were loaded successfully.
 403   | LoadFailed  Errors  -- ^ not all modules were loaded.
 404
 405 type Errors = [String]
 406
 407 data ErrMsg = ErrMsg {
 408         errMsgSeverity  :: Severity,  -- warning, error, etc.
 409         errMsgSpans     :: [SrcSpan],
 410         errMsgShortDoc  :: Doc,
 411         errMsgExtraInfo :: Doc
 412         }
 413 -}
 414
 415 data LoadHowMuch
 416    = LoadAllTargets
 417    | LoadUpTo Module
 418    | LoadDependenciesOf Module
 419
 420 -- | Try to load the program.  If a Module is supplied, then just
 421 -- attempt to load up to this target.  If no Module is supplied,
 422 -- then try to load all targets.
 423 load :: Session -> LoadHowMuch -> IO SuccessFlag
 424 load session how_much =
 425    loadMsgs session how_much ErrUtils.printErrorsAndWarnings
 426
 427 -- | Version of 'load' that takes a callback function to be invoked
 428 -- on compiler errors and warnings as they occur during compilation.
 429 loadMsgs :: Session -> LoadHowMuch -> (Messages-> IO ()) -> IO SuccessFlag
 430 loadMsgs s@(Session ref) how_much msg_act
 431    = do
 432         -- Dependency analysis first.  Note that this fixes the module graph:
 433         -- even if we don't get a fully successful upsweep, the full module
 434         -- graph is still retained in the Session.  We can tell which modules
 435         -- were successfully loaded by inspecting the Session's HPT.
 436         depanal s []
 437
 438         hsc_env <- readIORef ref
 439
 440         let hpt1      = hsc_HPT hsc_env
 441         let dflags    = hsc_dflags hsc_env
 442         let mod_graph = hsc_mod_graph hsc_env
 443
 444         let ghci_mode = ghcMode (hsc_dflags hsc_env) -- this never changes
 445         let verb      = verbosity dflags
 446
 447         -- The "bad" boot modules are the ones for which we have
 448         -- B.hs-boot in the module graph, but no B.hs
 449         -- The downsweep should have ensured this does not happen
 450         -- (see msDeps)
 451         let all_home_mods = [ms_mod s | s <- mod_graph, not (isBootSummary s)]
 452             bad_boot_mods = [s        | s <- mod_graph, isBootSummary s,
 453                                         not (ms_mod s `elem` all_home_mods)]
 454         ASSERT( null bad_boot_mods ) return ()
 455
 456         -- mg2_with_srcimps drops the hi-boot nodes, returning a
 457         -- graph with cycles.  Among other things, it is used for
 458         -- backing out partially complete cycles following a failed
 459         -- upsweep, and for removing from hpt all the modules
 460         -- not in strict downwards closure, during calls to compile.
 461         let mg2_with_srcimps :: [SCC ModSummary]
 462             mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing
 463
 464             -- check the stability property for each module.
 465             stable_mods@(stable_obj,stable_bco)
 466                 | BatchCompile <- ghci_mode = ([],[])
 467                 | otherwise = checkStability hpt1 mg2_with_srcimps all_home_mods
 468
 469             -- prune bits of the HPT which are definitely redundant now,
 470             -- to save space.
 471             pruned_hpt = pruneHomePackageTable hpt1
 472                                 (flattenSCCs mg2_with_srcimps)
 473                                 stable_mods
 474
 475         evaluate pruned_hpt
 476
 477         debugTraceMsg dflags 2 (showSDoc (text "Stable obj:" <+> ppr stable_obj $$
 478                                 text "Stable BCO:" <+> ppr stable_bco))
 479
 480         -- Unload any modules which are going to be re-linked this time around.
 481         let stable_linkables = [ linkable
 482                                | m <- stable_obj++stable_bco,
 483                                  Just hmi <- [lookupModuleEnv pruned_hpt m],
 484                                  Just linkable <- [hm_linkable hmi] ]
 485         unload hsc_env stable_linkables
 486
 487         -- We could at this point detect cycles which aren't broken by
 488         -- a source-import, and complain immediately, but it seems better
 489         -- to let upsweep_mods do this, so at least some useful work gets
 490         -- done before the upsweep is abandoned.
 491         --hPutStrLn stderr "after tsort:\n"
 492         --hPutStrLn stderr (showSDoc (vcat (map ppr mg2)))
 493
 494         -- Now do the upsweep, calling compile for each module in
 495         -- turn.  Final result is version 3 of everything.
 496
 497         -- Topologically sort the module graph, this time including hi-boot
 498         -- nodes, and possibly just including the portion of the graph
 499         -- reachable from the module specified in the 2nd argument to load.
 500         -- This graph should be cycle-free.
 501         -- If we're restricting the upsweep to a portion of the graph, we
 502         -- also want to retain everything that is still stable.
 503         let full_mg :: [SCC ModSummary]
 504             full_mg    = topSortModuleGraph False mod_graph Nothing
 505
 506             maybe_top_mod = case how_much of
 507                                 LoadUpTo m           -> Just m
 508                                 LoadDependenciesOf m -> Just m
 509                                 _                    -> Nothing
 510
 511             partial_mg0 :: [SCC ModSummary]
 512             partial_mg0 = topSortModuleGraph False mod_graph maybe_top_mod
 513
 514             -- LoadDependenciesOf m: we want the upsweep to stop just
 515             -- short of the specified module (unless the specified module
 516             -- is stable).
 517             partial_mg
 518                 | LoadDependenciesOf mod <- how_much
 519                 = ASSERT( case last partial_mg0 of
 520                             AcyclicSCC ms -> ms_mod ms == mod; _ -> False )
 521                   List.init partial_mg0
 522                 | otherwise
 523                 = partial_mg0
 524
 525             stable_mg =
 526                 [ AcyclicSCC ms
 527                 | AcyclicSCC ms <- full_mg,
 528                   ms_mod ms `elem` stable_obj++stable_bco,
 529                   ms_mod ms `notElem` [ ms_mod ms' |
 530                                         AcyclicSCC ms' <- partial_mg ] ]
 531
 532             mg = stable_mg ++ partial_mg
 533
 534         -- clean up between compilations
 535         let cleanup = cleanTempFilesExcept dflags
 536                           (ppFilesFromSummaries (flattenSCCs mg2_with_srcimps))
 537
 538         (upsweep_ok, hsc_env1, modsUpswept)
 539            <- upsweep (hsc_env { hsc_HPT = emptyHomePackageTable })
 540                            pruned_hpt stable_mods cleanup msg_act mg
 541
 542         -- Make modsDone be the summaries for each home module now
 543         -- available; this should equal the domain of hpt3.
 544         -- Get in in a roughly top .. bottom order (hence reverse).
 545
 546         let modsDone = reverse modsUpswept
 547
 548         -- Try and do linking in some form, depending on whether the
 549         -- upsweep was completely or only partially successful.
 550
 551         if succeeded upsweep_ok
 552
 553          then
 554            -- Easy; just relink it all.
 555            do debugTraceMsg dflags 2 "Upsweep completely successful."
 556
 557               -- Clean up after ourselves
 558               cleanTempFilesExcept dflags (ppFilesFromSummaries modsDone)
 559
 560               -- Issue a warning for the confusing case where the user
 561               -- said '-o foo' but we're not going to do any linking.
 562               -- We attempt linking if either (a) one of the modules is
 563               -- called Main, or (b) the user said -no-hs-main, indicating
 564               -- that main() is going to come from somewhere else.
 565               --
 566               let ofile = outputFile dflags
 567               let no_hs_main = dopt Opt_NoHsMain dflags
 568               let mb_main_mod = mainModIs dflags
 569               let
 570                 main_mod = mb_main_mod `orElse` "Main"
 571                 a_root_is_Main
 572                     = any ((==main_mod).moduleUserString.ms_mod)
 573                           mod_graph
 574                 do_linking = a_root_is_Main || no_hs_main
 575
 576               when (ghci_mode == BatchCompile && isJust ofile && not do_linking) $
 577                 debugTraceMsg dflags 1 ("Warning: output was redirected with -o, " ++
 578                                    "but no output will be generated\n" ++
 579                                    "because there is no " ++ main_mod ++ " module.")
 580
 581               -- link everything together
 582               linkresult <- link ghci_mode dflags do_linking (hsc_HPT hsc_env1)
 583
 584               loadFinish Succeeded linkresult ref hsc_env1
 585
 586          else
 587            -- Tricky.  We need to back out the effects of compiling any
 588            -- half-done cycles, both so as to clean up the top level envs
 589            -- and to avoid telling the interactive linker to link them.
 590            do debugTraceMsg dflags 2 "Upsweep partially successful."
 591
 592               let modsDone_names
 593                      = map ms_mod modsDone
 594               let mods_to_zap_names
 595                      = findPartiallyCompletedCycles modsDone_names
 596                           mg2_with_srcimps
 597               let mods_to_keep
 598                      = filter ((`notElem` mods_to_zap_names).ms_mod)
 599                           modsDone
 600
 601               let hpt4 = retainInTopLevelEnvs (map ms_mod mods_to_keep)
 602                                               (hsc_HPT hsc_env1)
 603
 604               -- Clean up after ourselves
 605               cleanTempFilesExcept dflags (ppFilesFromSummaries mods_to_keep)
 606
 607               -- there should be no Nothings where linkables should be, now
 608               ASSERT(all (isJust.hm_linkable)
 609                         (moduleEnvElts (hsc_HPT hsc_env))) do
 610
 611               -- Link everything together
 612               linkresult <- link ghci_mode dflags False hpt4
 613
 614               let hsc_env4 = hsc_env1{ hsc_HPT = hpt4 }
 615               loadFinish Failed linkresult ref hsc_env4
 616
 617 -- Finish up after a load.
 618
 619 -- If the link failed, unload everything and return.
 620 loadFinish all_ok Failed ref hsc_env
 621   = do unload hsc_env []
 622        writeIORef ref $! discardProg hsc_env
 623        return Failed
 624
 625 -- Empty the interactive context and set the module context to the topmost
 626 -- newly loaded module, or the Prelude if none were loaded.
 627 loadFinish all_ok Succeeded ref hsc_env
 628   = do writeIORef ref $! hsc_env{ hsc_IC = emptyInteractiveContext }
 629        return all_ok
 630
 631
 632 -- Forget the current program, but retain the persistent info in HscEnv
 633 discardProg :: HscEnv -> HscEnv
 634 discardProg hsc_env
 635   = hsc_env { hsc_mod_graph = emptyMG,
 636               hsc_IC = emptyInteractiveContext,
 637               hsc_HPT = emptyHomePackageTable }
 638
 639 -- used to fish out the preprocess output files for the purposes of
 640 -- cleaning up.  The preprocessed file *might* be the same as the
 641 -- source file, but that doesn't do any harm.
 642 ppFilesFromSummaries summaries = [ fn | Just fn <- map ms_hspp_file summaries ]
 643
 644 -- -----------------------------------------------------------------------------
 645 -- Check module
 646
 647 data CheckedModule =
 648   CheckedModule { parsedSource      :: ParsedSource,
 649                   renamedSource     :: Maybe RenamedSource,
 650                   typecheckedSource :: Maybe TypecheckedSource,
 651                   checkedModuleInfo :: Maybe ModuleInfo
 652                 }
 653
 654 type ParsedSource      = Located (HsModule RdrName)
 655 type RenamedSource     = HsGroup Name
 656 type TypecheckedSource = LHsBinds Id
 657
 658 -- | This is the way to get access to parsed and typechecked source code
 659 -- for a module.  'checkModule' loads all the dependencies of the specified
 660 -- module in the Session, and then attempts to typecheck the module.  If
 661 -- successful, it returns the abstract syntax for the module.
 662 checkModule :: Session -> Module -> (Messages -> IO ())
 663         -> IO (Maybe CheckedModule)
 664 checkModule session@(Session ref) mod msg_act = do
 665         -- load up the dependencies first
 666    r <- loadMsgs session (LoadDependenciesOf mod) msg_act
 667    if (failed r) then return Nothing else do
 668
 669         -- now parse & typecheck the module
 670    hsc_env <- readIORef ref
 671    let mg  = hsc_mod_graph hsc_env
 672    case [ ms | ms <- mg, ms_mod ms == mod ] of
 673         [] -> return Nothing
 674         (ms:_) -> do
 675            -- Add in the OPTIONS from the source file This is nasty:
 676            -- we've done this once already, in the compilation manager
 677            -- It might be better to cache the flags in the
 678            -- ml_hspp_file field, say
 679            let dflags0 = hsc_dflags hsc_env
 680                hspp_buf = expectJust "GHC.checkModule" (ms_hspp_buf ms)
 681                opts = getOptionsFromStringBuffer hspp_buf
 682            (dflags1,leftovers) <- parseDynamicFlags dflags0 (map snd opts)
 683            if (not (null leftovers))
 684                 then do let filename = fromJust (ml_hs_file (ms_location ms))
 685                         msg_act (optionsErrorMsgs leftovers opts filename)
 686                         return Nothing
 687                 else do
 688
 689            r <- hscFileCheck hsc_env{hsc_dflags=dflags1} msg_act ms
 690            case r of
 691                 HscFail ->
 692                    return Nothing
 693                 HscChecked parsed renamed Nothing ->
 694                    return (Just (CheckedModule {
 695                                         parsedSource = parsed,
 696                                         renamedSource = renamed,
 697                                         typecheckedSource = Nothing,
 698                                         checkedModuleInfo = Nothing }))
 699                 HscChecked parsed renamed
 700                            (Just (tc_binds, rdr_env, details)) -> do
 701                    let minf = ModuleInfo {
 702                                 minf_type_env = md_types details,
 703                                 minf_exports  = md_exports details,
 704                                 minf_rdr_env  = Just rdr_env
 705                               }
 706                    return (Just (CheckedModule {
 707                                         parsedSource = parsed,
 708                                         renamedSource = renamed,
 709                                         typecheckedSource = Just tc_binds,
 710                                         checkedModuleInfo = Just minf }))
 711
 712 -- ---------------------------------------------------------------------------
 713 -- Unloading
 714
 715 unload :: HscEnv -> [Linkable] -> IO ()
 716 unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables'
 717   = case ghcMode (hsc_dflags hsc_env) of
 718         BatchCompile  -> return ()
 719         JustTypecheck -> return ()
 720 #ifdef GHCI
 721         Interactive -> Linker.unload (hsc_dflags hsc_env) stable_linkables
 722 #else
 723         Interactive -> panic "unload: no interpreter"
 724 #endif
 725         other -> panic "unload: strange mode"
 726
 727 -- -----------------------------------------------------------------------------
 728 -- checkStability
 729
 730 {-
 731   Stability tells us which modules definitely do not need to be recompiled.
 732   There are two main reasons for having stability:
 733
 734    - avoid doing a complete upsweep of the module graph in GHCi when
 735      modules near the bottom of the tree have not changed.
 736
 737    - to tell GHCi when it can load object code: we can only load object code
 738      for a module when we also load object code fo  all of the imports of the
 739      module.  So we need to know that we will definitely not be recompiling
 740      any of these modules, and we can use the object code.
 741
 742   NB. stability is of no importance to BatchCompile at all, only Interactive.
 743   (ToDo: what about JustTypecheck?)
 744
 745   The stability check is as follows.  Both stableObject and
 746   stableBCO are used during the upsweep phase later.
 747
 748   -------------------
 749   stable m = stableObject m || stableBCO m
 750
 751   stableObject m =
 752         all stableObject (imports m)
 753         && old linkable does not exist, or is == on-disk .o
 754         && date(on-disk .o) > date(.hs)
 755
 756   stableBCO m =
 757         all stable (imports m)
 758         && date(BCO) > date(.hs)
 759   -------------------
 760
 761   These properties embody the following ideas:
 762
 763     - if a module is stable:
 764         - if it has been compiled in a previous pass (present in HPT)
 765           then it does not need to be compiled or re-linked.
 766         - if it has not been compiled in a previous pass,
 767           then we only need to read its .hi file from disk and
 768           link it to produce a ModDetails.
 769
 770     - if a modules is not stable, we will definitely be at least
 771       re-linking, and possibly re-compiling it during the upsweep.
 772       All non-stable modules can (and should) therefore be unlinked
 773       before the upsweep.
 774
 775     - Note that objects are only considered stable if they only depend
 776       on other objects.  We can't link object code against byte code.
 777 -}
 778
 779 checkStability
 780         :: HomePackageTable             -- HPT from last compilation
 781         -> [SCC ModSummary]             -- current module graph (cyclic)
 782         -> [Module]                     -- all home modules
 783         -> ([Module],                   -- stableObject
 784             [Module])                   -- stableBCO
 785
 786 checkStability hpt sccs all_home_mods = foldl checkSCC ([],[]) sccs
 787   where
 788    checkSCC (stable_obj, stable_bco) scc0
 789      | stableObjects = (scc_mods ++ stable_obj, stable_bco)
 790      | stableBCOs    = (stable_obj, scc_mods ++ stable_bco)
 791      | otherwise     = (stable_obj, stable_bco)
 792      where
 793         scc = flattenSCC scc0
 794         scc_mods = map ms_mod scc
 795         home_module m   = m `elem` all_home_mods && m `notElem` scc_mods
 796
 797         scc_allimps = nub (filter home_module (concatMap ms_allimps scc))
 798             -- all imports outside the current SCC, but in the home pkg
 799
 800         stable_obj_imps = map (`elem` stable_obj) scc_allimps
 801         stable_bco_imps = map (`elem` stable_bco) scc_allimps
 802
 803         stableObjects =
 804            and stable_obj_imps
 805            && all object_ok scc
 806
 807         stableBCOs =
 808            and (zipWith (||) stable_obj_imps stable_bco_imps)
 809            && all bco_ok scc
 810
 811         object_ok ms
 812           | Just t <- ms_obj_date ms  =  t >= ms_hs_date ms
 813                                          && same_as_prev t
 814           | otherwise = False
 815           where
 816              same_as_prev t = case lookupModuleEnv hpt (ms_mod ms) of
 817                                 Nothing  -> True
 818                                 Just hmi  | Just l <- hm_linkable hmi
 819                                  -> isObjectLinkable l && t == linkableTime l
 820                 -- why '>=' rather than '>' above?  If the filesystem stores
 821                 -- times to the nearset second, we may occasionally find that
 822                 -- the object & source have the same modification time,
 823                 -- especially if the source was automatically generated
 824                 -- and compiled.  Using >= is slightly unsafe, but it matches
 825                 -- make's behaviour.
 826
 827         bco_ok ms
 828           = case lookupModuleEnv hpt (ms_mod ms) of
 829                 Nothing  -> False
 830                 Just hmi  | Just l <- hm_linkable hmi ->
 831                         not (isObjectLinkable l) &&
 832                         linkableTime l >= ms_hs_date ms
 833
 834 ms_allimps :: ModSummary -> [Module]
 835 ms_allimps ms = ms_srcimps ms ++ ms_imps ms
 836
 837 -- -----------------------------------------------------------------------------
 838 -- Prune the HomePackageTable
 839
 840 -- Before doing an upsweep, we can throw away:
 841 --
 842 --   - For non-stable modules:
 843 --      - all ModDetails, all linked code
 844 --   - all unlinked code that is out of date with respect to
 845 --     the source file
 846 --
 847 -- This is VERY IMPORTANT otherwise we'll end up requiring 2x the
 848 -- space at the end of the upsweep, because the topmost ModDetails of the
 849 -- old HPT holds on to the entire type environment from the previous
 850 -- compilation.
 851
 852 pruneHomePackageTable
 853    :: HomePackageTable
 854    -> [ModSummary]
 855    -> ([Module],[Module])
 856    -> HomePackageTable
 857
 858 pruneHomePackageTable hpt summ (stable_obj, stable_bco)
 859   = mapModuleEnv prune hpt
 860   where prune hmi
 861           | is_stable modl = hmi'
 862           | otherwise      = hmi'{ hm_details = emptyModDetails }
 863           where
 864            modl = mi_module (hm_iface hmi)
 865            hmi' | Just l <- hm_linkable hmi, linkableTime l < ms_hs_date ms
 866                 = hmi{ hm_linkable = Nothing }
 867                 | otherwise
 868                 = hmi
 869                 where ms = expectJust "prune" (lookupModuleEnv ms_map modl)
 870
 871         ms_map = mkModuleEnv [(ms_mod ms, ms) | ms <- summ]
 872
 873         is_stable m = m `elem` stable_obj || m `elem` stable_bco
 874
 875 -- -----------------------------------------------------------------------------
 876
 877 -- Return (names of) all those in modsDone who are part of a cycle
 878 -- as defined by theGraph.
 879 findPartiallyCompletedCycles :: [Module] -> [SCC ModSummary] -> [Module]
 880 findPartiallyCompletedCycles modsDone theGraph
 881    = chew theGraph
 882      where
 883         chew [] = []
 884         chew ((AcyclicSCC v):rest) = chew rest    -- acyclic?  not interesting.
 885         chew ((CyclicSCC vs):rest)
 886            = let names_in_this_cycle = nub (map ms_mod vs)
 887                  mods_in_this_cycle
 888                     = nub ([done | done <- modsDone,
 889                                    done `elem` names_in_this_cycle])
 890                  chewed_rest = chew rest
 891              in
 892              if   notNull mods_in_this_cycle
 893                   && length mods_in_this_cycle < length names_in_this_cycle
 894              then mods_in_this_cycle ++ chewed_rest
 895              else chewed_rest
 896
 897 -- -----------------------------------------------------------------------------
 898 -- The upsweep
 899
 900 -- This is where we compile each module in the module graph, in a pass
 901 -- from the bottom to the top of the graph.
 902
 903 -- There better had not be any cyclic groups here -- we check for them.
 904
 905 upsweep
 906     :: HscEnv                   -- Includes initially-empty HPT
 907     -> HomePackageTable         -- HPT from last time round (pruned)
 908     -> ([Module],[Module])      -- stable modules (see checkStability)
 909     -> IO ()                    -- How to clean up unwanted tmp files
 910     -> (Messages -> IO ())      -- Compiler error message callback
 911     -> [SCC ModSummary]         -- Mods to do (the worklist)
 912     -> IO (SuccessFlag,
 913            HscEnv,              -- With an updated HPT
 914            [ModSummary])        -- Mods which succeeded
 915
 916 upsweep hsc_env old_hpt stable_mods cleanup msg_act mods
 917    = upsweep' hsc_env old_hpt stable_mods cleanup msg_act mods 1 (length mods)
 918
 919 upsweep' hsc_env old_hpt stable_mods cleanup msg_act
 920      [] _ _
 921    = return (Succeeded, hsc_env, [])
 922
 923 upsweep' hsc_env old_hpt stable_mods cleanup msg_act
 924      (CyclicSCC ms:_) _ _
 925    = do putMsg (showSDoc (cyclicModuleErr ms))
 926         return (Failed, hsc_env, [])
 927
 928 upsweep' hsc_env old_hpt stable_mods cleanup msg_act
 929      (AcyclicSCC mod:mods) mod_index nmods
 930    = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++
 931         --           show (map (moduleUserString.moduleName.mi_module.hm_iface)
 932         --                     (moduleEnvElts (hsc_HPT hsc_env)))
 933
 934         mb_mod_info <- upsweep_mod hsc_env old_hpt stable_mods msg_act mod
 935                        mod_index nmods
 936
 937         cleanup         -- Remove unwanted tmp files between compilations
 938
 939         case mb_mod_info of
 940             Nothing -> return (Failed, hsc_env, [])
 941             Just mod_info -> do
 942                 { let this_mod = ms_mod mod
 943
 944                         -- Add new info to hsc_env
 945                       hpt1     = extendModuleEnv (hsc_HPT hsc_env)
 946                                         this_mod mod_info
 947                       hsc_env1 = hsc_env { hsc_HPT = hpt1 }
 948
 949                         -- Space-saving: delete the old HPT entry
 950                         -- for mod BUT if mod is a hs-boot
 951                         -- node, don't delete it.  For the
 952                         -- interface, the HPT entry is probaby for the
 953                         -- main Haskell source file.  Deleting it
 954                         -- would force .. (what?? --SDM)
 955                       old_hpt1 | isBootSummary mod = old_hpt
 956                                | otherwise = delModuleEnv old_hpt this_mod
 957
 958                 ; (restOK, hsc_env2, modOKs)
 959                         <- upsweep' hsc_env1 old_hpt1 stable_mods cleanup
 960                                 msg_act mods (mod_index+1) nmods
 961                 ; return (restOK, hsc_env2, mod:modOKs)
 962                 }
 963
 964
 965 -- Compile a single module.  Always produce a Linkable for it if
 966 -- successful.  If no compilation happened, return the old Linkable.
 967 upsweep_mod :: HscEnv
 968             -> HomePackageTable
 969             -> ([Module],[Module])
 970             -> (Messages -> IO ())
 971             -> ModSummary
 972             -> Int  -- index of module
 973             -> Int  -- total number of modules
 974             -> IO (Maybe HomeModInfo)   -- Nothing => Failed
 975
 976 upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) msg_act summary mod_index nmods
 977    = do
 978         let
 979             this_mod    = ms_mod summary
 980             mb_obj_date = ms_obj_date summary
 981             obj_fn      = ml_obj_file (ms_location summary)
 982             hs_date     = ms_hs_date summary
 983
 984             compile_it :: Maybe Linkable -> IO (Maybe HomeModInfo)
 985             compile_it  = upsweep_compile hsc_env old_hpt this_mod
 986                                 msg_act summary mod_index nmods
 987
 988         case ghcMode (hsc_dflags hsc_env) of
 989             BatchCompile ->
 990                 case () of
 991                    -- Batch-compilating is easy: just check whether we have
 992                    -- an up-to-date object file.  If we do, then the compiler
 993                    -- needs to do a recompilation check.
 994                    _ | Just obj_date <- mb_obj_date, obj_date >= hs_date -> do
 995                            linkable <-
 996                                 findObjectLinkable this_mod obj_fn obj_date
 997                            compile_it (Just linkable)
 998
 999                      | otherwise ->
1000                            compile_it Nothing
1001
1002             interactive ->
1003                 case () of
1004                     _ | is_stable_obj, isJust old_hmi ->
1005                            return old_hmi
1006                         -- object is stable, and we have an entry in the
1007                         -- old HPT: nothing to do
1008
1009                       | is_stable_obj, isNothing old_hmi -> do
1010                            linkable <-
1011                                 findObjectLinkable this_mod obj_fn
1012                                         (expectJust "upseep1" mb_obj_date)
1013                            compile_it (Just linkable)
1014                         -- object is stable, but we need to load the interface
1015                         -- off disk to make a HMI.
1016
1017                       | is_stable_bco ->
1018                            ASSERT(isJust old_hmi) -- must be in the old_hpt
1019                            return old_hmi
1020                         -- BCO is stable: nothing to do
1021
1022                       | Just hmi <- old_hmi,
1023                         Just l <- hm_linkable hmi, not (isObjectLinkable l),
1024                         linkableTime l >= ms_hs_date summary ->
1025                            compile_it (Just l)
1026                         -- we have an old BCO that is up to date with respect
1027                         -- to the source: do a recompilation check as normal.
1028
1029                       | otherwise ->
1030                           compile_it Nothing
1031                         -- no existing code at all: we must recompile.
1032                    where
1033                     is_stable_obj = this_mod `elem` stable_obj
1034                     is_stable_bco = this_mod `elem` stable_bco
1035
1036                     old_hmi = lookupModuleEnv old_hpt this_mod
1037
1038 -- Run hsc to compile a module
1039 upsweep_compile hsc_env old_hpt this_mod msg_act summary
1040                 mod_index nmods
1041                 mb_old_linkable = do
1042   let
1043         -- The old interface is ok if it's in the old HPT
1044         --      a) we're compiling a source file, and the old HPT
1045         --         entry is for a source file
1046         --      b) we're compiling a hs-boot file
1047         -- Case (b) allows an hs-boot file to get the interface of its
1048         -- real source file on the second iteration of the compilation
1049         -- manager, but that does no harm.  Otherwise the hs-boot file
1050         -- will always be recompiled
1051
1052         mb_old_iface
1053                 = case lookupModuleEnv old_hpt this_mod of
1054                      Nothing                              -> Nothing
1055                      Just hm_info | isBootSummary summary -> Just iface
1056                                   | not (mi_boot iface)   -> Just iface
1057                                   | otherwise             -> Nothing
1058                                    where
1059                                      iface = hm_iface hm_info
1060
1061   compresult <- compile hsc_env msg_act summary mb_old_linkable mb_old_iface
1062                         mod_index nmods
1063
1064   case compresult of
1065         -- Compilation failed.  Compile may still have updated the PCS, tho.
1066         CompErrs -> return Nothing
1067
1068         -- Compilation "succeeded", and may or may not have returned a new
1069         -- linkable (depending on whether compilation was actually performed
1070         -- or not).
1071         CompOK new_details new_iface new_linkable
1072               -> do let new_info = HomeModInfo { hm_iface = new_iface,
1073                                                  hm_details = new_details,
1074                                                  hm_linkable = new_linkable }
1075                     return (Just new_info)
1076
1077
1078 -- Filter modules in the HPT
1079 retainInTopLevelEnvs :: [Module] -> HomePackageTable -> HomePackageTable
1080 retainInTopLevelEnvs keep_these hpt
1081    = mkModuleEnv [ (mod, expectJust "retain" mb_mod_info)
1082                  | mod <- keep_these
1083                  , let mb_mod_info = lookupModuleEnv hpt mod
1084                  , isJust mb_mod_info ]
1085
1086 -- ---------------------------------------------------------------------------
1087 -- Topological sort of the module graph
1088
1089 topSortModuleGraph
1090           :: Bool               -- Drop hi-boot nodes? (see below)
1091           -> [ModSummary]
1092           -> Maybe Module
1093           -> [SCC ModSummary]
1094 -- Calculate SCCs of the module graph, possibly dropping the hi-boot nodes
1095 -- The resulting list of strongly-connected-components is in topologically
1096 -- sorted order, starting with the module(s) at the bottom of the
1097 -- dependency graph (ie compile them first) and ending with the ones at
1098 -- the top.
1099 --
1100 -- Drop hi-boot nodes (first boolean arg)?
1101 --
1102 --   False:     treat the hi-boot summaries as nodes of the graph,
1103 --              so the graph must be acyclic
1104 --
1105 --   True:      eliminate the hi-boot nodes, and instead pretend
1106 --              the a source-import of Foo is an import of Foo
1107 --              The resulting graph has no hi-boot nodes, but can by cyclic
1108
1109 topSortModuleGraph drop_hs_boot_nodes summaries Nothing
1110   = stronglyConnComp (fst (moduleGraphNodes drop_hs_boot_nodes summaries))
1111 topSortModuleGraph drop_hs_boot_nodes summaries (Just mod)
1112   = stronglyConnComp (map vertex_fn (reachable graph root))
1113   where
1114         -- restrict the graph to just those modules reachable from
1115         -- the specified module.  We do this by building a graph with
1116         -- the full set of nodes, and determining the reachable set from
1117         -- the specified node.
1118         (nodes, lookup_key) = moduleGraphNodes drop_hs_boot_nodes summaries
1119         (graph, vertex_fn, key_fn) = graphFromEdges' nodes
1120         root
1121           | Just key <- lookup_key HsSrcFile mod, Just v <- key_fn key = v
1122           | otherwise  = throwDyn (ProgramError "module does not exist")
1123
1124 moduleGraphNodes :: Bool -> [ModSummary]
1125   -> ([(ModSummary, Int, [Int])], HscSource -> Module -> Maybe Int)
1126 moduleGraphNodes drop_hs_boot_nodes summaries = (nodes, lookup_key)
1127    where
1128         -- Drop hs-boot nodes by using HsSrcFile as the key
1129         hs_boot_key | drop_hs_boot_nodes = HsSrcFile
1130                     | otherwise          = HsBootFile
1131
1132         -- We use integers as the keys for the SCC algorithm
1133         nodes :: [(ModSummary, Int, [Int])]
1134         nodes = [(s, expectJust "topSort" (lookup_key (ms_hsc_src s) (ms_mod s)),
1135                      out_edge_keys hs_boot_key (ms_srcimps s) ++
1136                      out_edge_keys HsSrcFile   (ms_imps s)    )
1137                 | s <- summaries
1138                 , not (isBootSummary s && drop_hs_boot_nodes) ]
1139                 -- Drop the hi-boot ones if told to do so
1140
1141         key_map :: NodeMap Int
1142         key_map = listToFM ([(ms_mod s, ms_hsc_src s) | s <- summaries]
1143                            `zip` [1..])
1144
1145         lookup_key :: HscSource -> Module -> Maybe Int
1146         lookup_key hs_src mod = lookupFM key_map (mod, hs_src)
1147
1148         out_edge_keys :: HscSource -> [Module] -> [Int]
1149         out_edge_keys hi_boot ms = mapCatMaybes (lookup_key hi_boot) ms
1150                 -- If we want keep_hi_boot_nodes, then we do lookup_key with
1151                 -- the IsBootInterface parameter True; else False
1152
1153
1154 type NodeKey   = (Module, HscSource)      -- The nodes of the graph are
1155 type NodeMap a = FiniteMap NodeKey a      -- keyed by (mod, src_file_type) pairs
1156
1157 msKey :: ModSummary -> NodeKey
1158 msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot }) = (mod,boot)
1159
1160 emptyNodeMap :: NodeMap a
1161 emptyNodeMap = emptyFM
1162
1163 mkNodeMap :: [ModSummary] -> NodeMap ModSummary
1164 mkNodeMap summaries = listToFM [ (msKey s, s) | s <- summaries]
1165
1166 nodeMapElts :: NodeMap a -> [a]
1167 nodeMapElts = eltsFM
1168
1169 -- -----------------------------------------------------------------
1170 -- The unlinked image
1171 --
1172 -- The compilation manager keeps a list of compiled, but as-yet unlinked
1173 -- binaries (byte code or object code).  Even when it links bytecode
1174 -- it keeps the unlinked version so it can re-link it later without
1175 -- recompiling.
1176
1177 type UnlinkedImage = [Linkable] -- the unlinked images (should be a set, really)
1178
1179 findModuleLinkable_maybe :: [Linkable] -> Module -> Maybe Linkable
1180 findModuleLinkable_maybe lis mod
1181    = case [LM time nm us | LM time nm us <- lis, nm == mod] of
1182         []   -> Nothing
1183         [li] -> Just li
1184         many -> pprPanic "findModuleLinkable" (ppr mod)
1185
1186 delModuleLinkable :: [Linkable] -> Module -> [Linkable]
1187 delModuleLinkable ls mod = [ l | l@(LM _ nm _) <- ls, nm /= mod ]
1188
1189 -----------------------------------------------------------------------------
1190 -- Downsweep (dependency analysis)
1191
1192 -- Chase downwards from the specified root set, returning summaries
1193 -- for all home modules encountered.  Only follow source-import
1194 -- links.
1195
1196 -- We pass in the previous collection of summaries, which is used as a
1197 -- cache to avoid recalculating a module summary if the source is
1198 -- unchanged.
1199 --
1200 -- The returned list of [ModSummary] nodes has one node for each home-package
1201 -- module, plus one for any hs-boot files.  The imports of these nodes
1202 -- are all there, including the imports of non-home-package modules.
1203
1204 downsweep :: HscEnv
1205           -> [ModSummary]       -- Old summaries
1206           -> [Module]           -- Ignore dependencies on these; treat them as
1207                                 -- if they were package modules
1208           -> IO [ModSummary]
1209 downsweep hsc_env old_summaries excl_mods
1210    = do rootSummaries <- mapM getRootSummary roots
1211         checkDuplicates rootSummaries
1212         loop (concatMap msDeps rootSummaries)
1213              (mkNodeMap rootSummaries)
1214      where
1215         roots = hsc_targets hsc_env
1216
1217         old_summary_map :: NodeMap ModSummary
1218         old_summary_map = mkNodeMap old_summaries
1219
1220         getRootSummary :: Target -> IO ModSummary
1221         getRootSummary (Target (TargetFile file mb_phase) maybe_buf)
1222            = do exists <- doesFileExist file
1223                 if exists
1224                     then summariseFile hsc_env old_summaries file mb_phase maybe_buf
1225                     else do
1226                 throwDyn (CmdLineError ("can't find file: " ++ file))
1227         getRootSummary (Target (TargetModule modl) maybe_buf)
1228            = do maybe_summary <- summariseModule hsc_env old_summary_map Nothing False
1229                                            modl maybe_buf excl_mods
1230                 case maybe_summary of
1231                    Nothing -> packageModErr modl
1232                    Just s  -> return s
1233
1234         -- In a root module, the filename is allowed to diverge from the module
1235         -- name, so we have to check that there aren't multiple root files
1236         -- defining the same module (otherwise the duplicates will be silently
1237         -- ignored, leading to confusing behaviour).
1238         checkDuplicates :: [ModSummary] -> IO ()
1239         checkDuplicates summaries = mapM_ check summaries
1240           where check summ =
1241                   case dups of
1242                         []     -> return ()
1243                         [_one] -> return ()
1244                         many   -> multiRootsErr modl many
1245                    where modl = ms_mod summ
1246                          dups =
1247                            [ expectJust "checkDup" (ml_hs_file (ms_location summ'))
1248                            | summ' <- summaries, ms_mod summ' == modl ]
1249
1250         loop :: [(FilePath,Module,IsBootInterface)]
1251                         -- Work list: process these modules
1252              -> NodeMap ModSummary
1253                         -- Visited set
1254              -> IO [ModSummary]
1255                         -- The result includes the worklist, except
1256                         -- for those mentioned in the visited set
1257         loop [] done      = return (nodeMapElts done)
1258         loop ((cur_path, wanted_mod, is_boot) : ss) done
1259           | key `elemFM` done = loop ss done
1260           | otherwise         = do { mb_s <- summariseModule hsc_env old_summary_map
1261                                                  (Just cur_path) is_boot
1262                                                  wanted_mod Nothing excl_mods
1263                                    ; case mb_s of
1264                                         Nothing -> loop ss done
1265                                         Just s  -> loop (msDeps s ++ ss)
1266                                                         (addToFM done key s) }
1267           where
1268             key = (wanted_mod, if is_boot then HsBootFile else HsSrcFile)
1269
1270 msDeps :: ModSummary -> [(FilePath,             -- Importing module
1271                           Module,               -- Imported module
1272                           IsBootInterface)]      -- {-# SOURCE #-} import or not
1273 -- (msDeps s) returns the dependencies of the ModSummary s.
1274 -- A wrinkle is that for a {-# SOURCE #-} import we return
1275 --      *both* the hs-boot file
1276 --      *and* the source file
1277 -- as "dependencies".  That ensures that the list of all relevant
1278 -- modules always contains B.hs if it contains B.hs-boot.
1279 -- Remember, this pass isn't doing the topological sort.  It's
1280 -- just gathering the list of all relevant ModSummaries
1281 msDeps s =  concat [ [(f, m, True), (f,m,False)] | m <- ms_srcimps s]
1282          ++ [(f,m,False) | m <- ms_imps    s]
1283         where
1284           f = msHsFilePath s    -- Keep the importing module for error reporting
1285
1286
1287 -----------------------------------------------------------------------------
1288 -- Summarising modules
1289
1290 -- We have two types of summarisation:
1291 --
1292 --    * Summarise a file.  This is used for the root module(s) passed to
1293 --      cmLoadModules.  The file is read, and used to determine the root
1294 --      module name.  The module name may differ from the filename.
1295 --
1296 --    * Summarise a module.  We are given a module name, and must provide
1297 --      a summary.  The finder is used to locate the file in which the module
1298 --      resides.
1299
1300 summariseFile
1301         :: HscEnv
1302         -> [ModSummary]                 -- old summaries
1303         -> FilePath                     -- source file name
1304         -> Maybe Phase                  -- start phase
1305         -> Maybe (StringBuffer,ClockTime)
1306         -> IO ModSummary
1307
1308 summariseFile hsc_env old_summaries file mb_phase maybe_buf
1309         -- we can use a cached summary if one is available and the
1310         -- source file hasn't changed,  But we have to look up the summary
1311         -- by source file, rather than module name as we do in summarise.
1312    | Just old_summary <- findSummaryBySourceFile old_summaries file
1313    = do
1314         let location = ms_location old_summary
1315
1316                 -- return the cached summary if the source didn't change
1317         src_timestamp <- case maybe_buf of
1318                            Just (_,t) -> return t
1319                            Nothing    -> getModificationTime file
1320
1321         if ms_hs_date old_summary == src_timestamp
1322            then do -- update the object-file timestamp
1323                   obj_timestamp <- getObjTimestamp location False
1324                   return old_summary{ ms_obj_date = obj_timestamp }
1325            else
1326                 new_summary
1327
1328    | otherwise
1329    = new_summary
1330   where
1331     new_summary = do
1332         let dflags = hsc_dflags hsc_env
1333
1334         (dflags', hspp_fn, buf)
1335             <- preprocessFile dflags file mb_phase maybe_buf
1336
1337         (srcimps,the_imps,mod) <- getImports dflags' buf hspp_fn
1338
1339         -- Make a ModLocation for this file
1340         location <- mkHomeModLocation dflags mod file
1341
1342         -- Tell the Finder cache where it is, so that subsequent calls
1343         -- to findModule will find it, even if it's not on any search path
1344         addHomeModuleToFinder hsc_env mod location
1345
1346         src_timestamp <- case maybe_buf of
1347                            Just (_,t) -> return t
1348                            Nothing    -> getModificationTime file
1349
1350         obj_timestamp <- modificationTimeIfExists (ml_obj_file location)
1351
1352         return (ModSummary { ms_mod = mod, ms_hsc_src = HsSrcFile,
1353                              ms_location = location,
1354                              ms_hspp_file = Just hspp_fn,
1355                              ms_hspp_buf  = Just buf,
1356                              ms_srcimps = srcimps, ms_imps = the_imps,
1357                              ms_hs_date = src_timestamp,
1358                              ms_obj_date = obj_timestamp })
1359
1360 findSummaryBySourceFile :: [ModSummary] -> FilePath -> Maybe ModSummary
1361 findSummaryBySourceFile summaries file
1362   = case [ ms | ms <- summaries, HsSrcFile <- [ms_hsc_src ms],
1363                                  fromJust (ml_hs_file (ms_location ms)) == file ] of
1364         [] -> Nothing
1365         (x:xs) -> Just x
1366
1367 -- Summarise a module, and pick up source and timestamp.
1368 summariseModule
1369           :: HscEnv
1370           -> NodeMap ModSummary -- Map of old summaries
1371           -> Maybe FilePath     -- Importing module (for error messages)
1372           -> IsBootInterface    -- True <=> a {-# SOURCE #-} import
1373           -> Module             -- Imported module to be summarised
1374           -> Maybe (StringBuffer, ClockTime)
1375           -> [Module]           -- Modules to exclude
1376           -> IO (Maybe ModSummary)      -- Its new summary
1377
1378 summariseModule hsc_env old_summary_map cur_mod is_boot wanted_mod maybe_buf excl_mods
1379   | wanted_mod `elem` excl_mods
1380   = return Nothing
1381
1382   | Just old_summary <- lookupFM old_summary_map (wanted_mod, hsc_src)
1383   = do          -- Find its new timestamp; all the
1384                 -- ModSummaries in the old map have valid ml_hs_files
1385         let location = ms_location old_summary
1386             src_fn = expectJust "summariseModule" (ml_hs_file location)
1387
1388                 -- return the cached summary if the source didn't change
1389         src_timestamp <- case maybe_buf of
1390                            Just (_,t) -> return t
1391                            Nothing    -> getModificationTime src_fn
1392
1393         if ms_hs_date old_summary == src_timestamp
1394            then do -- update the object-file timestamp
1395                   obj_timestamp <- getObjTimestamp location is_boot
1396                   return (Just old_summary{ ms_obj_date = obj_timestamp })
1397            else
1398                 -- source changed: re-summarise
1399                 new_summary location src_fn maybe_buf src_timestamp
1400
1401   | otherwise
1402   = do  found <- findModule hsc_env wanted_mod True {-explicit-}
1403         case found of
1404              Found location pkg
1405                 | not (isHomePackage pkg) -> return Nothing
1406                         -- Drop external-pkg
1407                 | isJust (ml_hs_file location) -> just_found location
1408                         -- Home package
1409              err -> noModError dflags cur_mod wanted_mod err
1410                         -- Not found
1411   where
1412     dflags = hsc_dflags hsc_env
1413
1414     hsc_src = if is_boot then HsBootFile else HsSrcFile
1415
1416     just_found location = do
1417                 -- Adjust location to point to the hs-boot source file,
1418                 -- hi file, object file, when is_boot says so
1419         let location' | is_boot   = addBootSuffixLocn location
1420                       | otherwise = location
1421             src_fn = expectJust "summarise2" (ml_hs_file location')
1422
1423                 -- Check that it exists
1424                 -- It might have been deleted since the Finder last found it
1425         maybe_t <- modificationTimeIfExists src_fn
1426         case maybe_t of
1427           Nothing -> noHsFileErr cur_mod src_fn
1428           Just t  -> new_summary location' src_fn Nothing t
1429
1430
1431     new_summary location src_fn maybe_bug src_timestamp
1432       = do
1433         -- Preprocess the source file and get its imports
1434         -- The dflags' contains the OPTIONS pragmas
1435         (dflags', hspp_fn, buf) <- preprocessFile dflags src_fn Nothing maybe_buf
1436         (srcimps, the_imps, mod_name) <- getImports dflags' buf hspp_fn
1437
1438         when (mod_name /= wanted_mod) $
1439                 throwDyn (ProgramError
1440                    (showSDoc (text src_fn
1441                               <>  text ": file name does not match module name"
1442                               <+> quotes (ppr mod_name))))
1443
1444                 -- Find the object timestamp, and return the summary
1445         obj_timestamp <- getObjTimestamp location is_boot
1446
1447         return (Just ( ModSummary { ms_mod       = wanted_mod,
1448                                     ms_hsc_src   = hsc_src,
1449                                     ms_location  = location,
1450                                     ms_hspp_file = Just hspp_fn,
1451                                     ms_hspp_buf  = Just buf,
1452                                     ms_srcimps   = srcimps,
1453                                     ms_imps      = the_imps,
1454                                     ms_hs_date   = src_timestamp,
1455                                     ms_obj_date  = obj_timestamp }))
1456
1457
1458 getObjTimestamp location is_boot
1459   = if is_boot then return Nothing
1460                else modificationTimeIfExists (ml_obj_file location)
1461
1462
1463 preprocessFile :: DynFlags -> FilePath -> Maybe Phase -> Maybe (StringBuffer,ClockTime)
1464   -> IO (DynFlags, FilePath, StringBuffer)
1465 preprocessFile dflags src_fn mb_phase Nothing
1466   = do
1467         (dflags', hspp_fn) <- preprocess dflags (src_fn, mb_phase)
1468         buf <- hGetStringBuffer hspp_fn
1469         return (dflags', hspp_fn, buf)
1470
1471 preprocessFile dflags src_fn mb_phase (Just (buf, time))
1472   = do
1473         -- case we bypass the preprocessing stage?
1474         let
1475             local_opts = getOptionsFromStringBuffer buf
1476         --
1477         (dflags', errs) <- parseDynamicFlags dflags (map snd local_opts)
1478
1479         let
1480             needs_preprocessing
1481                 | Just (Unlit _) <- mb_phase    = True
1482                 | Nothing <- mb_phase, Unlit _ <- startPhase src_fn  = True
1483                   -- note: local_opts is only required if there's no Unlit phase
1484                 | dopt Opt_Cpp dflags'          = True
1485                 | dopt Opt_Pp  dflags'          = True
1486                 | otherwise                     = False
1487
1488         when needs_preprocessing $
1489            ghcError (ProgramError "buffer needs preprocesing; interactive check disabled")
1490
1491         return (dflags', src_fn, buf)
1492
1493
1494 -----------------------------------------------------------------------------
1495 --                      Error messages
1496 -----------------------------------------------------------------------------
1497
1498 noModError :: DynFlags -> Maybe FilePath -> Module -> FindResult -> IO ab
1499 -- ToDo: we don't have a proper line number for this error
1500 noModError dflags cur_mod wanted_mod err
1501   = throwDyn $ ProgramError $ showSDoc $
1502     vcat [cantFindError dflags wanted_mod err,
1503           nest 2 (parens (pp_where cur_mod))]
1504
1505 noHsFileErr cur_mod path
1506   = throwDyn $ CmdLineError $ showSDoc $
1507     vcat [text "Can't find" <+> text path,
1508           nest 2 (parens (pp_where cur_mod))]
1509
1510 pp_where Nothing  = text "one of the roots of the dependency analysis"
1511 pp_where (Just p) = text "imported from" <+> text p
1512
1513 packageModErr mod
1514   = throwDyn (CmdLineError (showSDoc (text "module" <+>
1515                                    quotes (ppr mod) <+>
1516                                    text "is a package module")))
1517
1518 multiRootsErr mod files
1519   = throwDyn (ProgramError (showSDoc (
1520         text "module" <+> quotes (ppr mod) <+>
1521         text "is defined in multiple files:" <+>
1522         sep (map text files))))
1523
1524 cyclicModuleErr :: [ModSummary] -> SDoc
1525 cyclicModuleErr ms
1526   = hang (ptext SLIT("Module imports form a cycle for modules:"))
1527        2 (vcat (map show_one ms))
1528   where
1529     show_one ms = sep [ show_mod (ms_hsc_src ms) (ms_mod ms),
1530                         nest 2 $ ptext SLIT("imports:") <+>
1531                                    (pp_imps HsBootFile (ms_srcimps ms)
1532                                    $$ pp_imps HsSrcFile  (ms_imps ms))]
1533     show_mod hsc_src mod = ppr mod <> text (hscSourceString hsc_src)
1534     pp_imps src mods = fsep (map (show_mod src) mods)
1535
1536
1537 -- | Inform GHC that the working directory has changed.  GHC will flush
1538 -- its cache of module locations, since it may no longer be valid.
1539 -- Note: if you change the working directory, you should also unload
1540 -- the current program (set targets to empty, followed by load).
1541 workingDirectoryChanged :: Session -> IO ()
1542 workingDirectoryChanged s = withSession s $ \hsc_env ->
1543   flushFinderCache (hsc_FC hsc_env)
1544
1545 -- -----------------------------------------------------------------------------
1546 -- inspecting the session
1547
1548 -- | Get the module dependency graph.
1549 getModuleGraph :: Session -> IO ModuleGraph -- ToDo: DiGraph ModSummary
1550 getModuleGraph s = withSession s (return . hsc_mod_graph)
1551
1552 isLoaded :: Session -> Module -> IO Bool
1553 isLoaded s m = withSession s $ \hsc_env ->
1554   return $! isJust (lookupModuleEnv (hsc_HPT hsc_env) m)
1555
1556 getBindings :: Session -> IO [TyThing]
1557 getBindings s = withSession s (return . nameEnvElts . ic_type_env . hsc_IC)
1558
1559 getPrintUnqual :: Session -> IO PrintUnqualified
1560 getPrintUnqual s = withSession s (return . icPrintUnqual . hsc_IC)
1561
1562 -- | Container for information about a 'Module'.
1563 data ModuleInfo = ModuleInfo {
1564         minf_type_env :: TypeEnv,
1565         minf_exports  :: NameSet,
1566         minf_rdr_env  :: Maybe GlobalRdrEnv
1567   }
1568         -- ToDo: this should really contain the ModIface too
1569         -- We don't want HomeModInfo here, because a ModuleInfo applies
1570         -- to package modules too.
1571
1572 -- | Request information about a loaded 'Module'
1573 getModuleInfo :: Session -> Module -> IO (Maybe ModuleInfo)
1574 getModuleInfo s mdl = withSession s $ \hsc_env -> do
1575   case lookupModuleEnv (hsc_HPT hsc_env) mdl of
1576     Nothing  -> do
1577 #ifdef GHCI
1578         mb_names <- getModuleExports hsc_env mdl
1579         case mb_names of
1580            Nothing -> return Nothing
1581            Just names -> do
1582                 eps <- readIORef (hsc_EPS hsc_env)
1583                 let
1584                     pte    = eps_PTE eps
1585                     n_list = nameSetToList names
1586                     tys    = [ ty | name <- n_list,
1587                                     Just ty <- [lookupTypeEnv pte name] ]
1588                 --
1589                 return (Just (ModuleInfo {
1590                                 minf_type_env = mkTypeEnv tys,
1591                                 minf_exports  = names,
1592                                 minf_rdr_env  = Just $! nameSetToGlobalRdrEnv names mdl
1593                         }))
1594 #else
1595         -- bogusly different for non-GHCI (ToDo)
1596         return Nothing
1597 #endif
1598     Just hmi ->
1599         let details = hm_details hmi in
1600         return (Just (ModuleInfo {
1601                         minf_type_env = md_types details,
1602                         minf_exports  = md_exports details,
1603                         minf_rdr_env  = mi_globals $! hm_iface hmi
1604                         }))
1605
1606         -- ToDo: we should be able to call getModuleInfo on a package module,
1607         -- even one that isn't loaded yet.
1608
1609 -- | The list of top-level entities defined in a module
1610 modInfoTyThings :: ModuleInfo -> [TyThing]
1611 modInfoTyThings minf = typeEnvElts (minf_type_env minf)
1612
1613 modInfoTopLevelScope :: ModuleInfo -> Maybe [Name]
1614 modInfoTopLevelScope minf
1615   = fmap (map gre_name . globalRdrEnvElts) (minf_rdr_env minf)
1616
1617 modInfoExports :: ModuleInfo -> [Name]
1618 modInfoExports minf = nameSetToList $! minf_exports minf
1619
1620 modInfoIsExportedName :: ModuleInfo -> Name -> Bool
1621 modInfoIsExportedName minf name = elemNameSet name (minf_exports minf)
1622
1623 modInfoPrintUnqualified :: ModuleInfo -> Maybe PrintUnqualified
1624 modInfoPrintUnqualified minf = fmap unQualInScope (minf_rdr_env minf)
1625
1626 modInfoLookupName :: Session -> ModuleInfo -> Name -> IO (Maybe TyThing)
1627 modInfoLookupName s minf name = withSession s $ \hsc_env -> do
1628    case lookupTypeEnv (minf_type_env minf) name of
1629      Just tyThing -> return (Just tyThing)
1630      Nothing      -> do
1631        eps <- readIORef (hsc_EPS hsc_env)
1632        return $! lookupType (hsc_HPT hsc_env) (eps_PTE eps) name
1633
1634 isDictonaryId :: Id -> Bool
1635 isDictonaryId id
1636   = case tcSplitSigmaTy (idType id) of { (tvs, theta, tau) -> isDictTy tau }
1637
1638 -- | Looks up a global name: that is, any top-level name in any
1639 -- visible module.  Unlike 'lookupName', lookupGlobalName does not use
1640 -- the interactive context, and therefore does not require a preceding
1641 -- 'setContext'.
1642 lookupGlobalName :: Session -> Name -> IO (Maybe TyThing)
1643 lookupGlobalName s name = withSession s $ \hsc_env -> do
1644    eps <- readIORef (hsc_EPS hsc_env)
1645    return $! lookupType (hsc_HPT hsc_env) (eps_PTE eps) name
1646
1647 #if 0
1648
1649 data ObjectCode
1650   = ByteCode
1651   | BinaryCode FilePath
1652
1653 -- ToDo: typechecks abstract syntax or renamed abstract syntax.  Issues:
1654 --   - typechecked syntax includes extra dictionary translation and
1655 --     AbsBinds which need to be translated back into something closer to
1656 --     the original source.
1657
1658 -- ToDo:
1659 --   - Data and Typeable instances for HsSyn.
1660
1661 -- ToDo:
1662 --   - things that aren't in the output of the renamer:
1663 --     - the export list
1664 --     - the imports
1665
1666 -- ToDo:
1667 --   - things that aren't in the output of the typechecker right now:
1668 --     - the export list
1669 --     - the imports
1670 --     - type signatures
1671 --     - type/data/newtype declarations
1672 --     - class declarations
1673 --     - instances
1674 --   - extra things in the typechecker's output:
1675 --     - default methods are turned into top-level decls.
1676 --     - dictionary bindings
1677
1678 -- ToDo: check for small transformations that happen to the syntax in
1679 -- the typechecker (eg. -e ==> negate e, perhaps for fromIntegral)
1680
1681 -- ToDo: maybe use TH syntax instead of IfaceSyn?  There's already a way
1682 -- to get from TyCons, Ids etc. to TH syntax (reify).
1683
1684 -- :browse will use either lm_toplev or inspect lm_interface, depending
1685 -- on whether the module is interpreted or not.
1686
1687 -- This is for reconstructing refactored source code
1688 -- Calls the lexer repeatedly.
1689 -- ToDo: add comment tokens to token stream
1690 getTokenStream :: Session -> Module -> IO [Located Token]
1691 #endif
1692
1693 -- -----------------------------------------------------------------------------
1694 -- Interactive evaluation
1695
1696 #ifdef GHCI
1697
1698 -- | Set the interactive evaluation context.
1699 --
1700 -- Setting the context doesn't throw away any bindings; the bindings
1701 -- we've built up in the InteractiveContext simply move to the new
1702 -- module.  They always shadow anything in scope in the current context.
1703 setContext :: Session
1704            -> [Module]  -- entire top level scope of these modules
1705            -> [Module]  -- exports only of these modules
1706            -> IO ()
1707 setContext (Session ref) toplevs exports = do
1708   hsc_env <- readIORef ref
1709   let old_ic  = hsc_IC     hsc_env
1710       hpt     = hsc_HPT    hsc_env
1711
1712   mapM_ (checkModuleExists hsc_env hpt) exports
1713   export_env  <- mkExportEnv hsc_env exports
1714   toplev_envs <- mapM (mkTopLevEnv hpt) toplevs
1715   let all_env = foldr plusGlobalRdrEnv export_env toplev_envs
1716   writeIORef ref hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplevs,
1717                                             ic_exports      = exports,
1718                                             ic_rn_gbl_env   = all_env } }
1719
1720 -- Make a GlobalRdrEnv based on the exports of the modules only.
1721 mkExportEnv :: HscEnv -> [Module] -> IO GlobalRdrEnv
1722 mkExportEnv hsc_env mods = do
1723   mb_name_sets <- mapM (getModuleExports hsc_env) mods
1724   let
1725         gres = [ nameSetToGlobalRdrEnv name_set mod
1726                | (Just name_set, mod) <- zip mb_name_sets mods ]
1727   --
1728   return $! foldr plusGlobalRdrEnv emptyGlobalRdrEnv gres
1729
1730 nameSetToGlobalRdrEnv :: NameSet -> Module -> GlobalRdrEnv
1731 nameSetToGlobalRdrEnv names mod =
1732   mkGlobalRdrEnv [ GRE  { gre_name = name, gre_prov = vanillaProv mod }
1733                  | name <- nameSetToList names ]
1734
1735 vanillaProv :: Module -> Provenance
1736 -- We're building a GlobalRdrEnv as if the user imported
1737 -- all the specified modules into the global interactive module
1738 vanillaProv mod = Imported [ImportSpec { is_mod = mod, is_as = mod,
1739                                          is_qual = False, is_explicit = False,
1740                                          is_loc = srcLocSpan interactiveSrcLoc }]
1741
1742 checkModuleExists :: HscEnv -> HomePackageTable -> Module -> IO ()
1743 checkModuleExists hsc_env hpt mod =
1744   case lookupModuleEnv hpt mod of
1745     Just mod_info -> return ()
1746     _not_a_home_module -> do
1747           res <- findPackageModule hsc_env mod True
1748           case res of
1749             Found _ _ -> return  ()
1750             err -> let msg = cantFindError (hsc_dflags hsc_env) mod err in
1751                    throwDyn (CmdLineError (showSDoc msg))
1752
1753 mkTopLevEnv :: HomePackageTable -> Module -> IO GlobalRdrEnv
1754 mkTopLevEnv hpt modl
1755  = case lookupModuleEnv hpt modl of
1756       Nothing ->
1757          throwDyn (ProgramError ("mkTopLevEnv: not a home module "
1758                         ++ showSDoc (pprModule modl)))
1759       Just details ->
1760          case mi_globals (hm_iface details) of
1761                 Nothing  ->
1762                    throwDyn (ProgramError ("mkTopLevEnv: not interpreted "
1763                                                 ++ showSDoc (pprModule modl)))
1764                 Just env -> return env
1765
1766 -- | Get the interactive evaluation context, consisting of a pair of the
1767 -- set of modules from which we take the full top-level scope, and the set
1768 -- of modules from which we take just the exports respectively.
1769 getContext :: Session -> IO ([Module],[Module])
1770 getContext s = withSession s (\HscEnv{ hsc_IC=ic } ->
1771                                 return (ic_toplev_scope ic, ic_exports ic))
1772
1773 -- | Returns 'True' if the specified module is interpreted, and hence has
1774 -- its full top-level scope available.
1775 moduleIsInterpreted :: Session -> Module -> IO Bool
1776 moduleIsInterpreted s modl = withSession s $ \h ->
1777  case lookupModuleEnv (hsc_HPT h) modl of
1778       Just details       -> return (isJust (mi_globals (hm_iface details)))
1779       _not_a_home_module -> return False
1780
1781 -- | Looks up an identifier in the current interactive context (for :info)
1782 {-# DEPRECATED getInfo "we should be using parseName/lookupName instead" #-}
1783 getInfo :: Session -> String -> IO [GetInfoResult]
1784 getInfo s id = withSession s $ \hsc_env -> hscGetInfo hsc_env id
1785
1786 -- | Returns all names in scope in the current interactive context
1787 getNamesInScope :: Session -> IO [Name]
1788 getNamesInScope s = withSession s $ \hsc_env -> do
1789   return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env))))
1790
1791 -- | Parses a string as an identifier, and returns the list of 'Name's that
1792 -- the identifier can refer to in the current interactive context.
1793 parseName :: Session -> String -> IO [Name]
1794 parseName s str = withSession s $ \hsc_env -> do
1795    maybe_rdr_name <- hscParseIdentifier (hsc_dflags hsc_env) str
1796    case maybe_rdr_name of
1797         Nothing -> return []
1798         Just (L _ rdr_name) -> do
1799             mb_names <- tcRnLookupRdrName hsc_env rdr_name
1800             case mb_names of
1801                 Nothing -> return []
1802                 Just ns -> return ns
1803                 -- ToDo: should return error messages
1804
1805 -- | Returns the 'TyThing' for a 'Name'.  The 'Name' may refer to any
1806 -- entity known to GHC, including 'Name's defined using 'runStmt'.
1807 lookupName :: Session -> Name -> IO (Maybe TyThing)
1808 lookupName s name = withSession s $ \hsc_env -> do
1809   case lookupTypeEnv (ic_type_env (hsc_IC hsc_env)) name of
1810         Just tt -> return (Just tt)
1811         Nothing -> do
1812             eps <- readIORef (hsc_EPS hsc_env)
1813             return $! lookupType (hsc_HPT hsc_env) (eps_PTE eps) name
1814
1815 -- -----------------------------------------------------------------------------
1816 -- Getting the type of an expression
1817
1818 -- | Get the type of an expression
1819 exprType :: Session -> String -> IO (Maybe Type)
1820 exprType s expr = withSession s $ \hsc_env -> do
1821    maybe_stuff <- hscTcExpr hsc_env expr
1822    case maybe_stuff of
1823         Nothing -> return Nothing
1824         Just ty -> return (Just tidy_ty)
1825              where
1826                 tidy_ty = tidyType emptyTidyEnv ty
1827                 dflags  = hsc_dflags hsc_env
1828
1829 -- -----------------------------------------------------------------------------
1830 -- Getting the kind of a type
1831
1832 -- | Get the kind of a  type
1833 typeKind  :: Session -> String -> IO (Maybe Kind)
1834 typeKind s str = withSession s $ \hsc_env -> do
1835    maybe_stuff <- hscKcType hsc_env str
1836    case maybe_stuff of
1837         Nothing -> return Nothing
1838         Just kind -> return (Just kind)
1839
1840 -----------------------------------------------------------------------------
1841 -- cmCompileExpr: compile an expression and deliver an HValue
1842
1843 compileExpr :: Session -> String -> IO (Maybe HValue)
1844 compileExpr s expr = withSession s $ \hsc_env -> do
1845   maybe_stuff <- hscStmt hsc_env ("let __cmCompileExpr = "++expr)
1846   case maybe_stuff of
1847         Nothing -> return Nothing
1848         Just (new_ic, names, hval) -> do
1849                         -- Run it!
1850                 hvals <- (unsafeCoerce# hval) :: IO [HValue]
1851
1852                 case (names,hvals) of
1853                   ([n],[hv]) -> return (Just hv)
1854                   _          -> panic "compileExpr"
1855
1856 -- -----------------------------------------------------------------------------
1857 -- running a statement interactively
1858
1859 data RunResult
1860   = RunOk [Name]                -- ^ names bound by this evaluation
1861   | RunFailed                   -- ^ statement failed compilation
1862   | RunException Exception      -- ^ statement raised an exception
1863
1864 -- | Run a statement in the current interactive context.  Statemenet
1865 -- may bind multple values.
1866 runStmt :: Session -> String -> IO RunResult
1867 runStmt (Session ref) expr
1868    = do
1869         hsc_env <- readIORef ref
1870
1871         -- Turn off -fwarn-unused-bindings when running a statement, to hide
1872         -- warnings about the implicit bindings we introduce.
1873         let dflags'  = dopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds
1874             hsc_env' = hsc_env{ hsc_dflags = dflags' }
1875
1876         maybe_stuff <- hscStmt hsc_env' expr
1877
1878         case maybe_stuff of
1879            Nothing -> return RunFailed
1880            Just (new_hsc_env, names, hval) -> do
1881
1882                 let thing_to_run = unsafeCoerce# hval :: IO [HValue]
1883                 either_hvals <- sandboxIO thing_to_run
1884
1885                 case either_hvals of
1886                     Left e -> do
1887                         -- on error, keep the *old* interactive context,
1888                         -- so that 'it' is not bound to something
1889                         -- that doesn't exist.
1890                         return (RunException e)
1891
1892                     Right hvals -> do
1893                         -- Get the newly bound things, and bind them.
1894                         -- Don't need to delete any shadowed bindings;
1895                         -- the new ones override the old ones.
1896                         extendLinkEnv (zip names hvals)
1897
1898                         writeIORef ref new_hsc_env
1899                         return (RunOk names)
1900
1901
1902 -- We run the statement in a "sandbox" to protect the rest of the
1903 -- system from anything the expression might do.  For now, this
1904 -- consists of just wrapping it in an exception handler, but see below
1905 -- for another version.
1906
1907 sandboxIO :: IO a -> IO (Either Exception a)
1908 sandboxIO thing = Exception.try thing
1909
1910 {-
1911 -- This version of sandboxIO runs the expression in a completely new
1912 -- RTS main thread.  It is disabled for now because ^C exceptions
1913 -- won't be delivered to the new thread, instead they'll be delivered
1914 -- to the (blocked) GHCi main thread.
1915
1916 -- SLPJ: when re-enabling this, reflect a wrong-stat error as an exception
1917
1918 sandboxIO :: IO a -> IO (Either Int (Either Exception a))
1919 sandboxIO thing = do
1920   st_thing <- newStablePtr (Exception.try thing)
1921   alloca $ \ p_st_result -> do
1922     stat <- rts_evalStableIO st_thing p_st_result
1923     freeStablePtr st_thing
1924     if stat == 1
1925         then do st_result <- peek p_st_result
1926                 result <- deRefStablePtr st_result
1927                 freeStablePtr st_result
1928                 return (Right result)
1929         else do
1930                 return (Left (fromIntegral stat))
1931
1932 foreign import "rts_evalStableIO"  {- safe -}
1933   rts_evalStableIO :: StablePtr (IO a) -> Ptr (StablePtr a) -> IO CInt
1934   -- more informative than the C type!
1935 -}
1936
1937 -- ---------------------------------------------------------------------------
1938 -- cmBrowseModule: get all the TyThings defined in a module
1939
1940 {-# DEPRECATED browseModule "we should be using getModuleInfo instead" #-}
1941 browseModule :: Session -> Module -> Bool -> IO [IfaceDecl]
1942 browseModule s modl exports_only = withSession s $ \hsc_env -> do
1943   mb_decls <- getModuleContents hsc_env modl exports_only
1944   case mb_decls of
1945         Nothing -> return []            -- An error of some kind
1946         Just ds -> return ds
1947
1948
1949 -----------------------------------------------------------------------------
1950 -- show a module and it's source/object filenames
1951
1952 showModule :: Session -> ModSummary -> IO String
1953 showModule s mod_summary = withSession s $ \hsc_env -> do
1954   case lookupModuleEnv (hsc_HPT hsc_env) (ms_mod mod_summary) of
1955         Nothing       -> panic "missing linkable"
1956         Just mod_info -> return (showModMsg obj_linkable mod_summary)
1957                       where
1958                          obj_linkable = isObjectLinkable (fromJust (hm_linkable mod_info))
1959
1960 #endif /* GHCI */