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