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