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