compiler/main/GHC.hs

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