compiler/main/GHC.hs

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