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(..) )
 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 )
 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 = 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 (ms_srcimps s) ++
1147                      out_edge_keys HsSrcFile   (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 Nothing False
1240                                            modl maybe_buf excl_mods
1241                 case maybe_summary of
1242                    Nothing -> packageModErr modl
1243                    Just s  -> return s
1244
1245         -- In a root module, the filename is allowed to diverge from the module
1246         -- name, so we have to check that there aren't multiple root files
1247         -- defining the same module (otherwise the duplicates will be silently
1248         -- ignored, leading to confusing behaviour).
1249         checkDuplicates :: [ModSummary] -> IO ()
1250         checkDuplicates summaries = mapM_ check summaries
1251           where check summ =
1252                   case dups of
1253                         []     -> return ()
1254                         [_one] -> return ()
1255                         many   -> multiRootsErr modl many
1256                    where modl = ms_mod summ
1257                          dups =
1258                            [ expectJust "checkDup" (ml_hs_file (ms_location summ'))
1259                            | summ' <- summaries, ms_mod summ' == modl ]
1260
1261         loop :: [(FilePath,Module,IsBootInterface)]
1262                         -- Work list: process these modules
1263              -> NodeMap ModSummary
1264                         -- Visited set
1265              -> IO [ModSummary]
1266                         -- The result includes the worklist, except
1267                         -- for those mentioned in the visited set
1268         loop [] done      = return (nodeMapElts done)
1269         loop ((cur_path, wanted_mod, is_boot) : ss) done
1270           | key `elemFM` done = loop ss done
1271           | otherwise         = do { mb_s <- summariseModule hsc_env old_summary_map
1272                                                  (Just cur_path) is_boot
1273                                                  wanted_mod Nothing excl_mods
1274                                    ; case mb_s of
1275                                         Nothing -> loop ss done
1276                                         Just s  -> loop (msDeps s ++ ss)
1277                                                         (addToFM done key s) }
1278           where
1279             key = (wanted_mod, if is_boot then HsBootFile else HsSrcFile)
1280
1281 msDeps :: ModSummary -> [(FilePath,             -- Importing module
1282                           Module,               -- Imported module
1283                           IsBootInterface)]      -- {-# SOURCE #-} import or not
1284 -- (msDeps s) returns the dependencies of the ModSummary s.
1285 -- A wrinkle is that for a {-# SOURCE #-} import we return
1286 --      *both* the hs-boot file
1287 --      *and* the source file
1288 -- as "dependencies".  That ensures that the list of all relevant
1289 -- modules always contains B.hs if it contains B.hs-boot.
1290 -- Remember, this pass isn't doing the topological sort.  It's
1291 -- just gathering the list of all relevant ModSummaries
1292 msDeps s =  concat [ [(f, m, True), (f,m,False)] | m <- ms_srcimps s]
1293          ++ [(f,m,False) | m <- ms_imps    s]
1294         where
1295           f = msHsFilePath s    -- Keep the importing module for error reporting
1296
1297
1298 -----------------------------------------------------------------------------
1299 -- Summarising modules
1300
1301 -- We have two types of summarisation:
1302 --
1303 --    * Summarise a file.  This is used for the root module(s) passed to
1304 --      cmLoadModules.  The file is read, and used to determine the root
1305 --      module name.  The module name may differ from the filename.
1306 --
1307 --    * Summarise a module.  We are given a module name, and must provide
1308 --      a summary.  The finder is used to locate the file in which the module
1309 --      resides.
1310
1311 summariseFile
1312         :: HscEnv
1313         -> [ModSummary]                 -- old summaries
1314         -> FilePath                     -- source file name
1315         -> Maybe Phase                  -- start phase
1316         -> Maybe (StringBuffer,ClockTime)
1317         -> IO ModSummary
1318
1319 summariseFile hsc_env old_summaries file mb_phase maybe_buf
1320         -- we can use a cached summary if one is available and the
1321         -- source file hasn't changed,  But we have to look up the summary
1322         -- by source file, rather than module name as we do in summarise.
1323    | Just old_summary <- findSummaryBySourceFile old_summaries file
1324    = do
1325         let location = ms_location old_summary
1326
1327                 -- return the cached summary if the source didn't change
1328         src_timestamp <- case maybe_buf of
1329                            Just (_,t) -> return t
1330                            Nothing    -> getModificationTime file
1331
1332         if ms_hs_date old_summary == src_timestamp
1333            then do -- update the object-file timestamp
1334                   obj_timestamp <- getObjTimestamp location False
1335                   return old_summary{ ms_obj_date = obj_timestamp }
1336            else
1337                 new_summary
1338
1339    | otherwise
1340    = new_summary
1341   where
1342     new_summary = do
1343         let dflags = hsc_dflags hsc_env
1344
1345         (dflags', hspp_fn, buf)
1346             <- preprocessFile dflags file mb_phase maybe_buf
1347
1348         (srcimps,the_imps,mod) <- getImports dflags' buf hspp_fn
1349
1350         -- Make a ModLocation for this file
1351         location <- mkHomeModLocation dflags mod file
1352
1353         -- Tell the Finder cache where it is, so that subsequent calls
1354         -- to findModule will find it, even if it's not on any search path
1355         addHomeModuleToFinder hsc_env mod location
1356
1357         src_timestamp <- case maybe_buf of
1358                            Just (_,t) -> return t
1359                            Nothing    -> getModificationTime file
1360
1361         obj_timestamp <- modificationTimeIfExists (ml_obj_file location)
1362
1363         return (ModSummary { ms_mod = mod, ms_hsc_src = HsSrcFile,
1364                              ms_location = location,
1365                              ms_hspp_file = Just hspp_fn,
1366                              ms_hspp_buf  = Just buf,
1367                              ms_srcimps = srcimps, ms_imps = the_imps,
1368                              ms_hs_date = src_timestamp,
1369                              ms_obj_date = obj_timestamp })
1370
1371 findSummaryBySourceFile :: [ModSummary] -> FilePath -> Maybe ModSummary
1372 findSummaryBySourceFile summaries file
1373   = case [ ms | ms <- summaries, HsSrcFile <- [ms_hsc_src ms],
1374                                  fromJust (ml_hs_file (ms_location ms)) == file ] of
1375         [] -> Nothing
1376         (x:xs) -> Just x
1377
1378 -- Summarise a module, and pick up source and timestamp.
1379 summariseModule
1380           :: HscEnv
1381           -> NodeMap ModSummary -- Map of old summaries
1382           -> Maybe FilePath     -- Importing module (for error messages)
1383           -> IsBootInterface    -- True <=> a {-# SOURCE #-} import
1384           -> Module             -- Imported module to be summarised
1385           -> Maybe (StringBuffer, ClockTime)
1386           -> [Module]           -- Modules to exclude
1387           -> IO (Maybe ModSummary)      -- Its new summary
1388
1389 summariseModule hsc_env old_summary_map cur_mod is_boot wanted_mod maybe_buf excl_mods
1390   | wanted_mod `elem` excl_mods
1391   = return Nothing
1392
1393   | Just old_summary <- lookupFM old_summary_map (wanted_mod, hsc_src)
1394   = do          -- Find its new timestamp; all the
1395                 -- ModSummaries in the old map have valid ml_hs_files
1396         let location = ms_location old_summary
1397             src_fn = expectJust "summariseModule" (ml_hs_file location)
1398
1399                 -- return the cached summary if the source didn't change
1400         src_timestamp <- case maybe_buf of
1401                            Just (_,t) -> return t
1402                            Nothing    -> getModificationTime src_fn
1403
1404         if ms_hs_date old_summary == src_timestamp
1405            then do -- update the object-file timestamp
1406                   obj_timestamp <- getObjTimestamp location is_boot
1407                   return (Just old_summary{ ms_obj_date = obj_timestamp })
1408            else
1409                 -- source changed: re-summarise
1410                 new_summary location src_fn maybe_buf src_timestamp
1411
1412   | otherwise
1413   = do  found <- findModule hsc_env wanted_mod True {-explicit-}
1414         case found of
1415              Found location pkg
1416                 | not (isHomePackage pkg) -> return Nothing
1417                         -- Drop external-pkg
1418                 | isJust (ml_hs_file location) -> just_found location
1419                         -- Home package
1420              err -> noModError dflags cur_mod wanted_mod err
1421                         -- Not found
1422   where
1423     dflags = hsc_dflags hsc_env
1424
1425     hsc_src = if is_boot then HsBootFile else HsSrcFile
1426
1427     just_found location = do
1428                 -- Adjust location to point to the hs-boot source file,
1429                 -- hi file, object file, when is_boot says so
1430         let location' | is_boot   = addBootSuffixLocn location
1431                       | otherwise = location
1432             src_fn = expectJust "summarise2" (ml_hs_file location')
1433
1434                 -- Check that it exists
1435                 -- It might have been deleted since the Finder last found it
1436         maybe_t <- modificationTimeIfExists src_fn
1437         case maybe_t of
1438           Nothing -> noHsFileErr cur_mod src_fn
1439           Just t  -> new_summary location' src_fn Nothing t
1440
1441
1442     new_summary location src_fn maybe_bug src_timestamp
1443       = do
1444         -- Preprocess the source file and get its imports
1445         -- The dflags' contains the OPTIONS pragmas
1446         (dflags', hspp_fn, buf) <- preprocessFile dflags src_fn Nothing maybe_buf
1447         (srcimps, the_imps, mod_name) <- getImports dflags' buf hspp_fn
1448
1449         when (mod_name /= wanted_mod) $
1450                 throwDyn (ProgramError
1451                    (showSDoc (text src_fn
1452                               <>  text ": file name does not match module name"
1453                               <+> quotes (ppr mod_name))))
1454
1455                 -- Find the object timestamp, and return the summary
1456         obj_timestamp <- getObjTimestamp location is_boot
1457
1458         return (Just ( ModSummary { ms_mod       = wanted_mod,
1459                                     ms_hsc_src   = hsc_src,
1460                                     ms_location  = location,
1461                                     ms_hspp_file = Just hspp_fn,
1462                                     ms_hspp_buf  = Just buf,
1463                                     ms_srcimps   = srcimps,
1464                                     ms_imps      = the_imps,
1465                                     ms_hs_date   = src_timestamp,
1466                                     ms_obj_date  = obj_timestamp }))
1467
1468
1469 getObjTimestamp location is_boot
1470   = if is_boot then return Nothing
1471                else modificationTimeIfExists (ml_obj_file location)
1472
1473
1474 preprocessFile :: DynFlags -> FilePath -> Maybe Phase -> Maybe (StringBuffer,ClockTime)
1475   -> IO (DynFlags, FilePath, StringBuffer)
1476 preprocessFile dflags src_fn mb_phase Nothing
1477   = do
1478         (dflags', hspp_fn) <- preprocess dflags (src_fn, mb_phase)
1479         buf <- hGetStringBuffer hspp_fn
1480         return (dflags', hspp_fn, buf)
1481
1482 preprocessFile dflags src_fn mb_phase (Just (buf, time))
1483   = do
1484         -- case we bypass the preprocessing stage?
1485         let
1486             local_opts = getOptionsFromStringBuffer buf
1487         --
1488         (dflags', errs) <- parseDynamicFlags dflags (map snd local_opts)
1489
1490         let
1491             needs_preprocessing
1492                 | Just (Unlit _) <- mb_phase    = True
1493                 | Nothing <- mb_phase, Unlit _ <- startPhase src_fn  = True
1494                   -- note: local_opts is only required if there's no Unlit phase
1495                 | dopt Opt_Cpp dflags'          = True
1496                 | dopt Opt_Pp  dflags'          = True
1497                 | otherwise                     = False
1498
1499         when needs_preprocessing $
1500            ghcError (ProgramError "buffer needs preprocesing; interactive check disabled")
1501
1502         return (dflags', src_fn, buf)
1503
1504
1505 -----------------------------------------------------------------------------
1506 --                      Error messages
1507 -----------------------------------------------------------------------------
1508
1509 noModError :: DynFlags -> Maybe FilePath -> Module -> FindResult -> IO ab
1510 -- ToDo: we don't have a proper line number for this error
1511 noModError dflags cur_mod wanted_mod err
1512   = throwDyn $ ProgramError $ showSDoc $
1513     vcat [cantFindError dflags wanted_mod err,
1514           nest 2 (parens (pp_where cur_mod))]
1515
1516 noHsFileErr cur_mod path
1517   = throwDyn $ CmdLineError $ showSDoc $
1518     vcat [text "Can't find" <+> text path,
1519           nest 2 (parens (pp_where cur_mod))]
1520
1521 pp_where Nothing  = text "one of the roots of the dependency analysis"
1522 pp_where (Just p) = text "imported from" <+> text p
1523
1524 packageModErr mod
1525   = throwDyn (CmdLineError (showSDoc (text "module" <+>
1526                                    quotes (ppr mod) <+>
1527                                    text "is a package module")))
1528
1529 multiRootsErr mod files
1530   = throwDyn (ProgramError (showSDoc (
1531         text "module" <+> quotes (ppr mod) <+>
1532         text "is defined in multiple files:" <+>
1533         sep (map text files))))
1534
1535 cyclicModuleErr :: [ModSummary] -> SDoc
1536 cyclicModuleErr ms
1537   = hang (ptext SLIT("Module imports form a cycle for modules:"))
1538        2 (vcat (map show_one ms))
1539   where
1540     show_one ms = sep [ show_mod (ms_hsc_src ms) (ms_mod ms),
1541                         nest 2 $ ptext SLIT("imports:") <+>
1542                                    (pp_imps HsBootFile (ms_srcimps ms)
1543                                    $$ pp_imps HsSrcFile  (ms_imps ms))]
1544     show_mod hsc_src mod = ppr mod <> text (hscSourceString hsc_src)
1545     pp_imps src mods = fsep (map (show_mod src) mods)
1546
1547
1548 -- | Inform GHC that the working directory has changed.  GHC will flush
1549 -- its cache of module locations, since it may no longer be valid.
1550 -- Note: if you change the working directory, you should also unload
1551 -- the current program (set targets to empty, followed by load).
1552 workingDirectoryChanged :: Session -> IO ()
1553 workingDirectoryChanged s = withSession s $ \hsc_env ->
1554   flushFinderCache (hsc_FC hsc_env)
1555
1556 -- -----------------------------------------------------------------------------
1557 -- inspecting the session
1558
1559 -- | Get the module dependency graph.
1560 getModuleGraph :: Session -> IO ModuleGraph -- ToDo: DiGraph ModSummary
1561 getModuleGraph s = withSession s (return . hsc_mod_graph)
1562
1563 isLoaded :: Session -> Module -> IO Bool
1564 isLoaded s m = withSession s $ \hsc_env ->
1565   return $! isJust (lookupModuleEnv (hsc_HPT hsc_env) m)
1566
1567 getBindings :: Session -> IO [TyThing]
1568 getBindings s = withSession s (return . nameEnvElts . ic_type_env . hsc_IC)
1569
1570 getPrintUnqual :: Session -> IO PrintUnqualified
1571 getPrintUnqual s = withSession s (return . icPrintUnqual . hsc_IC)
1572
1573 -- | Container for information about a 'Module'.
1574 data ModuleInfo = ModuleInfo {
1575         minf_type_env  :: TypeEnv,
1576         minf_exports   :: NameSet,
1577         minf_rdr_env   :: Maybe GlobalRdrEnv,   -- Nothing for a compiled/package mod
1578         minf_instances :: [Instance]
1579         -- ToDo: this should really contain the ModIface too
1580   }
1581         -- We don't want HomeModInfo here, because a ModuleInfo applies
1582         -- to package modules too.
1583
1584 -- | Request information about a loaded 'Module'
1585 getModuleInfo :: Session -> Module -> IO (Maybe ModuleInfo)
1586 getModuleInfo s mdl = withSession s $ \hsc_env -> do
1587   case lookupModuleEnv (hsc_HPT hsc_env) mdl of
1588     Nothing  -> do
1589 #ifdef GHCI
1590         mb_names <- getModuleExports hsc_env mdl
1591         case mb_names of
1592            Nothing -> return Nothing
1593            Just names -> do
1594                 eps <- readIORef (hsc_EPS hsc_env)
1595                 let
1596                     pte    = eps_PTE eps
1597                     n_list = nameSetToList names
1598                     tys    = [ ty | name <- n_list,
1599                                     Just ty <- [lookupTypeEnv pte name] ]
1600                 --
1601                 return (Just (ModuleInfo {
1602                                 minf_type_env  = mkTypeEnv tys,
1603                                 minf_exports   = names,
1604                                 minf_rdr_env   = Just $! nameSetToGlobalRdrEnv names mdl,
1605                                 minf_instances = error "getModuleInfo: instances for package module unimplemented"
1606                         }))
1607 #else
1608         -- bogusly different for non-GHCI (ToDo)
1609         return Nothing
1610 #endif
1611     Just hmi ->
1612         let details = hm_details hmi in
1613         return (Just (ModuleInfo {
1614                         minf_type_env  = md_types details,
1615                         minf_exports   = md_exports details,
1616                         minf_rdr_env   = mi_globals $! hm_iface hmi,
1617                         minf_instances = md_insts details
1618                         }))
1619
1620         -- ToDo: we should be able to call getModuleInfo on a package module,
1621         -- even one that isn't loaded yet.
1622
1623 -- | The list of top-level entities defined in a module
1624 modInfoTyThings :: ModuleInfo -> [TyThing]
1625 modInfoTyThings minf = typeEnvElts (minf_type_env minf)
1626
1627 modInfoTopLevelScope :: ModuleInfo -> Maybe [Name]
1628 modInfoTopLevelScope minf
1629   = fmap (map gre_name . globalRdrEnvElts) (minf_rdr_env minf)
1630
1631 modInfoExports :: ModuleInfo -> [Name]
1632 modInfoExports minf = nameSetToList $! minf_exports minf
1633
1634 -- | Returns the instances defined by the specified module.
1635 -- Warning: currently unimplemented for package modules.
1636 modInfoInstances :: ModuleInfo -> [Instance]
1637 modInfoInstances = minf_instances
1638
1639 modInfoIsExportedName :: ModuleInfo -> Name -> Bool
1640 modInfoIsExportedName minf name = elemNameSet name (minf_exports minf)
1641
1642 modInfoPrintUnqualified :: ModuleInfo -> Maybe PrintUnqualified
1643 modInfoPrintUnqualified minf = fmap unQualInScope (minf_rdr_env minf)
1644
1645 modInfoLookupName :: Session -> ModuleInfo -> Name -> IO (Maybe TyThing)
1646 modInfoLookupName s minf name = withSession s $ \hsc_env -> do
1647    case lookupTypeEnv (minf_type_env minf) name of
1648      Just tyThing -> return (Just tyThing)
1649      Nothing      -> do
1650        eps <- readIORef (hsc_EPS hsc_env)
1651        return $! lookupType (hsc_HPT hsc_env) (eps_PTE eps) name
1652
1653 isDictonaryId :: Id -> Bool
1654 isDictonaryId id
1655   = case tcSplitSigmaTy (idType id) of { (tvs, theta, tau) -> isDictTy tau }
1656
1657 -- | Looks up a global name: that is, any top-level name in any
1658 -- visible module.  Unlike 'lookupName', lookupGlobalName does not use
1659 -- the interactive context, and therefore does not require a preceding
1660 -- 'setContext'.
1661 lookupGlobalName :: Session -> Name -> IO (Maybe TyThing)
1662 lookupGlobalName s name = withSession s $ \hsc_env -> do
1663    eps <- readIORef (hsc_EPS hsc_env)
1664    return $! lookupType (hsc_HPT hsc_env) (eps_PTE eps) name
1665
1666 #if 0
1667
1668 data ObjectCode
1669   = ByteCode
1670   | BinaryCode FilePath
1671
1672 -- ToDo: typechecks abstract syntax or renamed abstract syntax.  Issues:
1673 --   - typechecked syntax includes extra dictionary translation and
1674 --     AbsBinds which need to be translated back into something closer to
1675 --     the original source.
1676
1677 -- ToDo:
1678 --   - Data and Typeable instances for HsSyn.
1679
1680 -- ToDo:
1681 --   - things that aren't in the output of the renamer:
1682 --     - the export list
1683 --     - the imports
1684
1685 -- ToDo:
1686 --   - things that aren't in the output of the typechecker right now:
1687 --     - the export list
1688 --     - the imports
1689 --     - type signatures
1690 --     - type/data/newtype declarations
1691 --     - class declarations
1692 --     - instances
1693 --   - extra things in the typechecker's output:
1694 --     - default methods are turned into top-level decls.
1695 --     - dictionary bindings
1696
1697 -- ToDo: check for small transformations that happen to the syntax in
1698 -- the typechecker (eg. -e ==> negate e, perhaps for fromIntegral)
1699
1700 -- ToDo: maybe use TH syntax instead of IfaceSyn?  There's already a way
1701 -- to get from TyCons, Ids etc. to TH syntax (reify).
1702
1703 -- :browse will use either lm_toplev or inspect lm_interface, depending
1704 -- on whether the module is interpreted or not.
1705
1706 -- This is for reconstructing refactored source code
1707 -- Calls the lexer repeatedly.
1708 -- ToDo: add comment tokens to token stream
1709 getTokenStream :: Session -> Module -> IO [Located Token]
1710 #endif
1711
1712 -- -----------------------------------------------------------------------------
1713 -- Interactive evaluation
1714
1715 #ifdef GHCI
1716
1717 -- | Set the interactive evaluation context.
1718 --
1719 -- Setting the context doesn't throw away any bindings; the bindings
1720 -- we've built up in the InteractiveContext simply move to the new
1721 -- module.  They always shadow anything in scope in the current context.
1722 setContext :: Session
1723            -> [Module]  -- entire top level scope of these modules
1724            -> [Module]  -- exports only of these modules
1725            -> IO ()
1726 setContext (Session ref) toplevs exports = do
1727   hsc_env <- readIORef ref
1728   let old_ic  = hsc_IC     hsc_env
1729       hpt     = hsc_HPT    hsc_env
1730
1731   mapM_ (checkModuleExists hsc_env hpt) exports
1732   export_env  <- mkExportEnv hsc_env exports
1733   toplev_envs <- mapM (mkTopLevEnv hpt) toplevs
1734   let all_env = foldr plusGlobalRdrEnv export_env toplev_envs
1735   writeIORef ref hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplevs,
1736                                             ic_exports      = exports,
1737                                             ic_rn_gbl_env   = all_env } }
1738
1739 -- Make a GlobalRdrEnv based on the exports of the modules only.
1740 mkExportEnv :: HscEnv -> [Module] -> IO GlobalRdrEnv
1741 mkExportEnv hsc_env mods = do
1742   mb_name_sets <- mapM (getModuleExports hsc_env) mods
1743   let
1744         gres = [ nameSetToGlobalRdrEnv name_set mod
1745                | (Just name_set, mod) <- zip mb_name_sets mods ]
1746   --
1747   return $! foldr plusGlobalRdrEnv emptyGlobalRdrEnv gres
1748
1749 nameSetToGlobalRdrEnv :: NameSet -> Module -> GlobalRdrEnv
1750 nameSetToGlobalRdrEnv names mod =
1751   mkGlobalRdrEnv [ GRE  { gre_name = name, gre_prov = vanillaProv mod }
1752                  | name <- nameSetToList names ]
1753
1754 vanillaProv :: Module -> Provenance
1755 -- We're building a GlobalRdrEnv as if the user imported
1756 -- all the specified modules into the global interactive module
1757 vanillaProv mod = Imported [ImportSpec { is_mod = mod, is_as = mod,
1758                                          is_qual = False, is_explicit = False,
1759                                          is_loc = srcLocSpan interactiveSrcLoc }]
1760
1761 checkModuleExists :: HscEnv -> HomePackageTable -> Module -> IO ()
1762 checkModuleExists hsc_env hpt mod =
1763   case lookupModuleEnv hpt mod of
1764     Just mod_info -> return ()
1765     _not_a_home_module -> do
1766           res <- findPackageModule hsc_env mod True
1767           case res of
1768             Found _ _ -> return  ()
1769             err -> let msg = cantFindError (hsc_dflags hsc_env) mod err in
1770                    throwDyn (CmdLineError (showSDoc msg))
1771
1772 mkTopLevEnv :: HomePackageTable -> Module -> IO GlobalRdrEnv
1773 mkTopLevEnv hpt modl
1774  = case lookupModuleEnv hpt modl of
1775       Nothing ->
1776          throwDyn (ProgramError ("mkTopLevEnv: not a home module "
1777                         ++ showSDoc (pprModule modl)))
1778       Just details ->
1779          case mi_globals (hm_iface details) of
1780                 Nothing  ->
1781                    throwDyn (ProgramError ("mkTopLevEnv: not interpreted "
1782                                                 ++ showSDoc (pprModule modl)))
1783                 Just env -> return env
1784
1785 -- | Get the interactive evaluation context, consisting of a pair of the
1786 -- set of modules from which we take the full top-level scope, and the set
1787 -- of modules from which we take just the exports respectively.
1788 getContext :: Session -> IO ([Module],[Module])
1789 getContext s = withSession s (\HscEnv{ hsc_IC=ic } ->
1790                                 return (ic_toplev_scope ic, ic_exports ic))
1791
1792 -- | Returns 'True' if the specified module is interpreted, and hence has
1793 -- its full top-level scope available.
1794 moduleIsInterpreted :: Session -> Module -> IO Bool
1795 moduleIsInterpreted s modl = withSession s $ \h ->
1796  case lookupModuleEnv (hsc_HPT h) modl of
1797       Just details       -> return (isJust (mi_globals (hm_iface details)))
1798       _not_a_home_module -> return False
1799
1800 -- | Looks up an identifier in the current interactive context (for :info)
1801 {-# DEPRECATED getInfo "we should be using parseName/lookupName instead" #-}
1802 getInfo :: Session -> String -> IO [GetInfoResult]
1803 getInfo s id = withSession s $ \hsc_env -> hscGetInfo hsc_env id
1804
1805 -- | Returns all names in scope in the current interactive context
1806 getNamesInScope :: Session -> IO [Name]
1807 getNamesInScope s = withSession s $ \hsc_env -> do
1808   return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env))))
1809
1810 -- | Parses a string as an identifier, and returns the list of 'Name's that
1811 -- the identifier can refer to in the current interactive context.
1812 parseName :: Session -> String -> IO [Name]
1813 parseName s str = withSession s $ \hsc_env -> do
1814    maybe_rdr_name <- hscParseIdentifier (hsc_dflags hsc_env) str
1815    case maybe_rdr_name of
1816         Nothing -> return []
1817         Just (L _ rdr_name) -> do
1818             mb_names <- tcRnLookupRdrName hsc_env rdr_name
1819             case mb_names of
1820                 Nothing -> return []
1821                 Just ns -> return ns
1822                 -- ToDo: should return error messages
1823
1824 -- | Returns the 'TyThing' for a 'Name'.  The 'Name' may refer to any
1825 -- entity known to GHC, including 'Name's defined using 'runStmt'.
1826 lookupName :: Session -> Name -> IO (Maybe TyThing)
1827 lookupName s name = withSession s $ \hsc_env -> do
1828   case lookupTypeEnv (ic_type_env (hsc_IC hsc_env)) name of
1829         Just tt -> return (Just tt)
1830         Nothing -> do
1831             eps <- readIORef (hsc_EPS hsc_env)
1832             return $! lookupType (hsc_HPT hsc_env) (eps_PTE eps) name
1833
1834 -- -----------------------------------------------------------------------------
1835 -- Getting the type of an expression
1836
1837 -- | Get the type of an expression
1838 exprType :: Session -> String -> IO (Maybe Type)
1839 exprType s expr = withSession s $ \hsc_env -> do
1840    maybe_stuff <- hscTcExpr hsc_env expr
1841    case maybe_stuff of
1842         Nothing -> return Nothing
1843         Just ty -> return (Just tidy_ty)
1844              where
1845                 tidy_ty = tidyType emptyTidyEnv ty
1846                 dflags  = hsc_dflags hsc_env
1847
1848 -- -----------------------------------------------------------------------------
1849 -- Getting the kind of a type
1850
1851 -- | Get the kind of a  type
1852 typeKind  :: Session -> String -> IO (Maybe Kind)
1853 typeKind s str = withSession s $ \hsc_env -> do
1854    maybe_stuff <- hscKcType hsc_env str
1855    case maybe_stuff of
1856         Nothing -> return Nothing
1857         Just kind -> return (Just kind)
1858
1859 -----------------------------------------------------------------------------
1860 -- cmCompileExpr: compile an expression and deliver an HValue
1861
1862 compileExpr :: Session -> String -> IO (Maybe HValue)
1863 compileExpr s expr = withSession s $ \hsc_env -> do
1864   maybe_stuff <- hscStmt hsc_env ("let __cmCompileExpr = "++expr)
1865   case maybe_stuff of
1866         Nothing -> return Nothing
1867         Just (new_ic, names, hval) -> do
1868                         -- Run it!
1869                 hvals <- (unsafeCoerce# hval) :: IO [HValue]
1870
1871                 case (names,hvals) of
1872                   ([n],[hv]) -> return (Just hv)
1873                   _          -> panic "compileExpr"
1874
1875 -- -----------------------------------------------------------------------------
1876 -- running a statement interactively
1877
1878 data RunResult
1879   = RunOk [Name]                -- ^ names bound by this evaluation
1880   | RunFailed                   -- ^ statement failed compilation
1881   | RunException Exception      -- ^ statement raised an exception
1882
1883 -- | Run a statement in the current interactive context.  Statemenet
1884 -- may bind multple values.
1885 runStmt :: Session -> String -> IO RunResult
1886 runStmt (Session ref) expr
1887    = do
1888         hsc_env <- readIORef ref
1889
1890         -- Turn off -fwarn-unused-bindings when running a statement, to hide
1891         -- warnings about the implicit bindings we introduce.
1892         let dflags'  = dopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds
1893             hsc_env' = hsc_env{ hsc_dflags = dflags' }
1894
1895         maybe_stuff <- hscStmt hsc_env' expr
1896
1897         case maybe_stuff of
1898            Nothing -> return RunFailed
1899            Just (new_hsc_env, names, hval) -> do
1900
1901                 let thing_to_run = unsafeCoerce# hval :: IO [HValue]
1902                 either_hvals <- sandboxIO thing_to_run
1903
1904                 case either_hvals of
1905                     Left e -> do
1906                         -- on error, keep the *old* interactive context,
1907                         -- so that 'it' is not bound to something
1908                         -- that doesn't exist.
1909                         return (RunException e)
1910
1911                     Right hvals -> do
1912                         -- Get the newly bound things, and bind them.
1913                         -- Don't need to delete any shadowed bindings;
1914                         -- the new ones override the old ones.
1915                         extendLinkEnv (zip names hvals)
1916
1917                         writeIORef ref new_hsc_env
1918                         return (RunOk names)
1919
1920
1921 -- We run the statement in a "sandbox" to protect the rest of the
1922 -- system from anything the expression might do.  For now, this
1923 -- consists of just wrapping it in an exception handler, but see below
1924 -- for another version.
1925
1926 sandboxIO :: IO a -> IO (Either Exception a)
1927 sandboxIO thing = Exception.try thing
1928
1929 {-
1930 -- This version of sandboxIO runs the expression in a completely new
1931 -- RTS main thread.  It is disabled for now because ^C exceptions
1932 -- won't be delivered to the new thread, instead they'll be delivered
1933 -- to the (blocked) GHCi main thread.
1934
1935 -- SLPJ: when re-enabling this, reflect a wrong-stat error as an exception
1936
1937 sandboxIO :: IO a -> IO (Either Int (Either Exception a))
1938 sandboxIO thing = do
1939   st_thing <- newStablePtr (Exception.try thing)
1940   alloca $ \ p_st_result -> do
1941     stat <- rts_evalStableIO st_thing p_st_result
1942     freeStablePtr st_thing
1943     if stat == 1
1944         then do st_result <- peek p_st_result
1945                 result <- deRefStablePtr st_result
1946                 freeStablePtr st_result
1947                 return (Right result)
1948         else do
1949                 return (Left (fromIntegral stat))
1950
1951 foreign import "rts_evalStableIO"  {- safe -}
1952   rts_evalStableIO :: StablePtr (IO a) -> Ptr (StablePtr a) -> IO CInt
1953   -- more informative than the C type!
1954 -}
1955
1956 -- ---------------------------------------------------------------------------
1957 -- cmBrowseModule: get all the TyThings defined in a module
1958
1959 {-# DEPRECATED browseModule "we should be using getModuleInfo instead" #-}
1960 browseModule :: Session -> Module -> Bool -> IO [IfaceDecl]
1961 browseModule s modl exports_only = withSession s $ \hsc_env -> do
1962   mb_decls <- getModuleContents hsc_env modl exports_only
1963   case mb_decls of
1964         Nothing -> return []            -- An error of some kind
1965         Just ds -> return ds
1966
1967
1968 -----------------------------------------------------------------------------
1969 -- show a module and it's source/object filenames
1970
1971 showModule :: Session -> ModSummary -> IO String
1972 showModule s mod_summary = withSession s $ \hsc_env -> do
1973   case lookupModuleEnv (hsc_HPT hsc_env) (ms_mod mod_summary) of
1974         Nothing       -> panic "missing linkable"
1975         Just mod_info -> return (showModMsg obj_linkable mod_summary)
1976                       where
1977                          obj_linkable = isObjectLinkable (fromJust (hm_linkable mod_info))
1978
1979 #endif /* GHCI */