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