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