GHC.hs 80.8 KB
Newer Older
1
-- -----------------------------------------------------------------------------
2
--
3
-- (c) The University of Glasgow, 2005
4 5 6
--
-- The GHC API
--
7
-- -----------------------------------------------------------------------------
8 9 10

module GHC (
	-- * Initialisation
11
	Session,
12 13 14 15 16
	defaultErrorHandler,
	defaultCleanupHandler,
	newSession,

	-- * Flags and settings
17
	DynFlags(..), DynFlag(..), Severity(..), HscTarget(..), dopt,
18
        GhcMode(..), GhcLink(..), defaultObjectTarget,
19
	parseDynamicFlags,
20 21
	getSessionDynFlags,
	setSessionDynFlags,
22
        parseStaticFlags,
23 24

	-- * Targets
25
	Target(..), TargetId(..), Phase,
26 27 28
	setTargets,
	getTargets,
	addTarget,
29
	removeTarget,
30 31
	guessTarget,
	
32 33 34 35 36 37
        -- * Extending the program scope 
        extendGlobalRdrScope,  -- :: Session -> [GlobalRdrElt] -> IO ()
        setGlobalRdrScope,     -- :: Session -> [GlobalRdrElt] -> IO ()
        extendGlobalTypeScope, -- :: Session -> [Id] -> IO ()
        setGlobalTypeScope,    -- :: Session -> [Id] -> IO ()

38
	-- * Loading\/compiling the program
39
	depanal,
40
	load, LoadHowMuch(..), SuccessFlag(..),	-- also does depanal
41
	workingDirectoryChanged,
Simon Marlow's avatar
Simon Marlow committed
42
	checkModule, checkAndLoadModule, CheckedModule(..),
43
	TypecheckedSource, ParsedSource, RenamedSource,
44 45
        compileToCore, compileToCoreModule, compileToCoreSimplified,
        compileCoreToObj,
46

47 48 49
	-- * Parsing Haddock comments
	parseHaddockComment,

50
	-- * Inspecting the module structure of the program
Simon Marlow's avatar
Simon Marlow committed
51
	ModuleGraph, ModSummary(..), ms_mod_name, ModLocation(..),
52
	getModuleGraph,
53
	isLoaded,
54 55
	topSortModuleGraph,

56 57 58 59
	-- * Inspecting modules
	ModuleInfo,
	getModuleInfo,
	modInfoTyThings,
60
	modInfoTopLevelScope,
61
        modInfoExports,
62
	modInfoInstances,
63 64
	modInfoIsExportedName,
	modInfoLookupName,
65
	lookupGlobalName,
66
        mkPrintUnqualifiedForModule,
67

68 69 70
	-- * Printing
	PrintUnqualified, alwaysQualify,

71 72
	-- * Interactive evaluation
	getBindings, getPrintUnqual,
Simon Marlow's avatar
Simon Marlow committed
73
        findModule,
74 75
#ifdef GHCI
	setContext, getContext,	
76
	getNamesInScope,
Simon Marlow's avatar
Simon Marlow committed
77
	getRdrNamesInScope,
78
        getGRE,
79
	moduleIsInterpreted,
80
	getInfo,
81 82
	exprType,
	typeKind,
83
	parseName,
84
	RunResult(..),  
85 86 87 88
	runStmt, SingleStep(..),
        resume,
        Resume(resumeStmt, resumeThreadId, resumeBreakInfo, resumeSpan,
               resumeHistory, resumeHistoryIx),
89
        History(historyBreakInfo, historyEnclosingDecl), 
90
        GHC.getHistorySpan, getHistoryModule,
91 92
        getResumeContext,
        abandon, abandonAll,
93 94
        InteractiveEval.back,
        InteractiveEval.forward,
95
	showModule,
96
        isModuleInterpreted,
Simon Marlow's avatar
Simon Marlow committed
97
	InteractiveEval.compileExpr, HValue, dynCompileExpr,
98
	lookupName,
99
        GHC.obtainTerm, GHC.obtainTerm1, GHC.obtainTermB, reconstructType,
100
        modInfoModBreaks,
101 102
        ModBreaks(..), BreakIndex,
        BreakInfo(breakInfo_number, breakInfo_module),
103
        BreakArray, setBreakOn, setBreakOff, getBreak,
104 105 106
#endif

	-- * Abstract syntax elements
107

Simon Marlow's avatar
Simon Marlow committed
108 109 110
        -- ** Packages
        PackageId,

111
	-- ** Modules
Simon Marlow's avatar
Simon Marlow committed
112 113
	Module, mkModule, pprModule, moduleName, modulePackageId,
        ModuleName, mkModuleName, moduleNameString,
114

115
	-- ** Names
116
	Name, 
Simon Marlow's avatar
Simon Marlow committed
117
	isExternalName, nameModule, pprParenSymName, nameSrcSpan,
118
	NamedThing(..),
Simon Marlow's avatar
Simon Marlow committed
119
	RdrName(Qual,Unqual),
120 121
	
	-- ** Identifiers
122
	Id, idType,
123
	isImplicitId, isDeadBinder,
124
	isExportedId, isLocalId, isGlobalId,
125
	isRecordSelector,
126
	isPrimOpId, isFCallId, isClassOpId_maybe,
127 128
	isDataConWorkId, idDataCon,
	isBottomingId, isDictonaryId,
129
	recordSelectorFieldLabel,
130 131 132

	-- ** Type constructors
	TyCon, 
133
	tyConTyVars, tyConDataCons, tyConArity,
134
	isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon,
135 136
	isOpenTyCon,
	synTyConDefn, synTyConType, synTyConResKind,
137

138 139 140 141
	-- ** Type variables
	TyVar,
	alphaTyVars,

142 143
	-- ** Data constructors
	DataCon,
144 145 146 147
	dataConSig, dataConType, dataConTyCon, dataConFieldLabels,
	dataConIsInfix, isVanillaDataCon,
	dataConStrictMarks,  
	StrictnessMark(..), isMarkedStrict,
148 149 150

	-- ** Classes
	Class, 
151 152
	classMethods, classSCTheta, classTvsFds,
	pprFundeps,
153

154
	-- ** Instances
155
	Instance, 
156
	instanceDFunId, pprInstance, pprInstanceHdr,
157

158
	-- ** Types and Kinds
159 160
	Type, splitForAllTys, funResultTy, 
	pprParendType, pprTypeApp, 
161
	Kind,
162 163
	PredType,
	ThetaType, pprThetaArrow,
164 165

	-- ** Entities
166 167
	TyThing(..), 

168 169 170
	-- ** Syntax
	module HsSyn, -- ToDo: remove extraneous bits

171 172 173 174 175 176 177 178
	-- ** Fixities
	FixityDirection(..), 
	defaultFixity, maxPrecedence, 
	negateFixity,
	compareFixity,

	-- ** Source locations
	SrcLoc, pprDefnLoc,
Simon Marlow's avatar
Simon Marlow committed
179
        mkSrcLoc, isGoodSrcLoc, noSrcLoc,
Simon Marlow's avatar
Simon Marlow committed
180 181
	srcLocFile, srcLocLine, srcLocCol,
        SrcSpan,
Simon Marlow's avatar
Simon Marlow committed
182
        mkSrcSpan, srcLocSpan, isGoodSrcSpan, noSrcSpan,
Simon Marlow's avatar
Simon Marlow committed
183 184 185 186
        srcSpanStart, srcSpanEnd,
	srcSpanFile, 
        srcSpanStartLine, srcSpanEndLine, 
        srcSpanStartCol, srcSpanEndCol,
187

188 189 190 191
	-- * Exceptions
	GhcException(..), showGhcException,

	-- * Miscellaneous
192 193
	sessionHscEnv,
	cyclicModuleErr,
194 195
  ) where

196 197 198
{-
 ToDo:

199
  * inline bits of HscMain here to simplify layering: hscTcExpr, hscStmt.
200 201 202 203 204 205
  * what StaticFlags should we expose, if any?
-}

#include "HsVersions.h"

#ifdef GHCI
mnislaih's avatar
mnislaih committed
206
import qualified Linker
207
import Linker           ( HValue )
208
import ByteCodeInstr
209
import BreakArray
210 211
import NameSet
import InteractiveEval
212
import TcRnDriver
213 214
#endif

215
import TcIface
Simon Marlow's avatar
Simon Marlow committed
216
import TcRnTypes        hiding (LIE)
217
import TcRnMonad        ( initIfaceCheck )
218 219 220
import Packages
import NameSet
import RdrName
221
import HsSyn 
222
import Type             hiding (typeKind)
223
import TcType           hiding (typeKind)
224 225
import Id
import Var              hiding (setIdType)
226
import TysPrim		( alphaTyVars )
227 228 229 230 231
import TyCon
import Class
import FunDeps
import DataCon
import Name             hiding ( varName )
232
import OccName		( parenSymOcc )
233 234 235
import InstEnv		( Instance, instanceDFunId, pprInstance, pprInstanceHdr,
                          emptyInstEnv )
import FamInstEnv       ( emptyFamInstEnv )
236
import SrcLoc
237
import CoreSyn
238
import TidyPgm
239
import DriverPipeline
240
import DriverPhases	( HscSource(..), Phase(..), isHaskellSrcFilename, startPhase )
241
import HeaderInfo	( getImports, getOptions )
242
import Finder
Simon Marlow's avatar
Simon Marlow committed
243
import HscMain
244 245
import HscTypes
import DynFlags
246
import StaticFlags
247 248
import SysTools     ( initSysTools, cleanTempFiles, cleanTempFilesExcept,
                      cleanTempDirs )
249
import Module
Simon Marlow's avatar
Simon Marlow committed
250
import UniqFM
251 252
import UniqSet
import Unique
253 254
import FiniteMap
import Panic
255
import Digraph
256
import Bag		( unitBag, listToBag )
257
import ErrUtils		( Severity(..), showPass, fatalErrorMsg, debugTraceMsg,
258 259
			  mkPlainErrMsg, printBagOfErrors, printBagOfWarnings,
			  WarnMsg )
260
import qualified ErrUtils
261
import Util
262
import StringBuffer	( StringBuffer, hGetStringBuffer )
263
import Outputable
264
import BasicTypes
265
import Maybes		( expectJust, mapCatMaybes )
266
import HaddockParse
267
import HaddockLex       ( tokenise )
268 269

import Control.Concurrent
270 271
import System.Directory ( getModificationTime, doesFileExist,
                          getCurrentDirectory )
272 273
import Data.Maybe
import Data.List
274
import qualified Data.List as List
275
import Control.Monad
276
import System.Exit	( exitWith, ExitCode(..) )
277
import System.Time	( ClockTime, getClockTime )
278 279 280
import Control.Exception as Exception hiding (handle)
import Data.IORef
import System.IO
281
import System.IO.Error	( try, isDoesNotExistError )
Ian Lynagh's avatar
Ian Lynagh committed
282
import Prelude hiding (init)
283

284

285
-- -----------------------------------------------------------------------------
286
-- Exception handlers
287 288 289 290 291

-- | Install some default exception handlers and run the inner computation.
-- Unless you want to handle exceptions yourself, you should wrap this around
-- the top level of your program.  The default handlers output the error
-- message(s) to stderr and exit cleanly.
292 293
defaultErrorHandler :: DynFlags -> IO a -> IO a
defaultErrorHandler dflags inner = 
294 295 296 297 298
  -- top-level exception handler: any unrecognised exception is a compiler bug.
  handle (\exception -> do
  	   hFlush stdout
	   case exception of
		-- an IO exception probably isn't our fault, so don't panic
299 300
		IOException _ ->
		  fatalErrorMsg dflags (text (show exception))
301
		AsyncException StackOverflow ->
302 303 304
		  fatalErrorMsg dflags (text "stack overflow: use +RTS -K<size> to increase it")
		_other ->
		  fatalErrorMsg dflags (text (show (Panic (show exception))))
305 306 307
	   exitWith (ExitFailure 1)
         ) $

308 309
  -- program errors: messages with locations attached.  Sometimes it is
  -- convenient to just throw these as exceptions.
310
  handleDyn (\dyn -> do printBagOfErrors dflags (unitBag dyn)
311 312 313
			exitWith (ExitFailure 1)) $

  -- error messages propagated as exceptions
314 315 316 317 318
  handleDyn (\dyn -> do
  		hFlush stdout
  		case dyn of
		     PhaseFailed _ code -> exitWith code
		     Interrupted -> exitWith (ExitFailure 1)
319
		     _ -> do fatalErrorMsg dflags (text (show (dyn :: GhcException)))
320 321 322 323 324 325 326 327
			     exitWith (ExitFailure 1)
	    ) $
  inner

-- | Install a default cleanup handler to remove temporary files
-- deposited by a GHC run.  This is seperate from
-- 'defaultErrorHandler', because you might want to override the error
-- handling, but still get the ordinary cleanup behaviour.
328 329
defaultCleanupHandler :: DynFlags -> IO a -> IO a
defaultCleanupHandler dflags inner = 
330
    -- make sure we clean up after ourselves
331 332
    later (do cleanTempFiles dflags
              cleanTempDirs dflags
333 334 335 336 337
          )
          -- exceptions will be blocked while we clean the temporary files,
          -- so there shouldn't be any difficulty if we receive further
          -- signals.
    inner
338 339 340 341


-- | Starts a new session.  A session consists of a set of loaded
-- modules, a set of options (DynFlags), and an interactive context.
342
-- ToDo: explain argument [[mb_top_dir]]
343 344
newSession :: Maybe FilePath -> IO Session
newSession mb_top_dir = do
345 346
  -- catch ^C
  main_thread <- myThreadId
347
  modifyMVar_ interruptTargetThread (return . (main_thread :))
348 349
  installSignalHandlers

350
  initStaticOpts
351 352
  dflags0 <- initSysTools mb_top_dir defaultDynFlags
  dflags  <- initDynFlags dflags0
353
  env <- newHscEnv dflags
354
  ref <- newIORef env
355 356 357 358 359 360 361
  return (Session ref)

-- tmp: this breaks the abstraction, but required because DriverMkDepend
-- needs to call the Finder.  ToDo: untangle this.
sessionHscEnv :: Session -> IO HscEnv
sessionHscEnv (Session ref) = readIORef ref

362 363 364 365 366
-- -----------------------------------------------------------------------------
-- Flags & settings

-- | Grabs the DynFlags from the Session
getSessionDynFlags :: Session -> IO DynFlags
367
getSessionDynFlags s = withSession s (return . hsc_dflags)
368

369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385
-- | Updates the DynFlags in a Session.  This also reads
-- the package database (unless it has already been read),
-- and prepares the compilers knowledge about packages.  It
-- can be called again to load new packages: just add new
-- package flags to (packageFlags dflags).
--
-- Returns a list of new packages that may need to be linked in using
-- the dynamic linker (see 'linkPackages') as a result of new package
-- flags.  If you are not doing linking or doing static linking, you
-- can ignore the list of packages returned.
--
setSessionDynFlags :: Session -> DynFlags -> IO [PackageId]
setSessionDynFlags (Session ref) dflags = do
  hsc_env <- readIORef ref
  (dflags', preload) <- initPackages dflags
  writeIORef ref $! hsc_env{ hsc_dflags = dflags' }
  return preload
386

387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403
-- | If there is no -o option, guess the name of target executable
-- by using top-level source file name as a base.
guessOutputFile :: Session -> IO ()
guessOutputFile s = modifySession s $ \env ->
    let dflags = hsc_dflags env
        mod_graph = hsc_mod_graph env
        mainModuleSrcPath, guessedName :: Maybe String
        mainModuleSrcPath = do
            let isMain = (== mainModIs dflags) . ms_mod
            [ms] <- return (filter isMain mod_graph)
            ml_hs_file (ms_location ms)
        guessedName = fmap basenameOf mainModuleSrcPath
    in
    case outputFile dflags of
        Just _ -> env
        Nothing -> env { hsc_dflags = dflags { outputFile = guessedName } }

404
-- -----------------------------------------------------------------------------
405
-- Targets
406 407 408 409 410 411

-- ToDo: think about relative vs. absolute file paths. And what
-- happens when the current directory changes.

-- | Sets the targets for this session.  Each target may be a module name
-- or a filename.  The targets correspond to the set of root modules for
412
-- the program\/library.  Unloading the current program is achieved by
413
-- setting the current set of targets to be empty, followed by load.
414
setTargets :: Session -> [Target] -> IO ()
415
setTargets s targets = modifySession s (\h -> h{ hsc_targets = targets })
416 417

-- | returns the current set of targets
418 419
getTargets :: Session -> IO [Target]
getTargets s = withSession s (return . hsc_targets)
420

421
-- | Add another target
422 423 424
addTarget :: Session -> Target -> IO ()
addTarget s target
  = modifySession s (\h -> h{ hsc_targets = target : hsc_targets h })
425

426 427 428 429 430 431
-- | Remove a target
removeTarget :: Session -> TargetId -> IO ()
removeTarget s target_id
  = modifySession s (\h -> h{ hsc_targets = filter (hsc_targets h) })
  where
   filter targets = [ t | t@(Target id _) <- targets, id /= target_id ]
432

433 434 435 436 437 438 439 440 441
-- Attempts to guess what Target a string refers to.  This function implements
-- the --make/GHCi command-line syntax for filenames: 
--
-- 	- if the string looks like a Haskell source filename, then interpret
--	  it as such
--	- if adding a .hs or .lhs suffix yields the name of an existing file,
--	  then use that
-- 	- otherwise interpret the string as a module name
--
442 443 444 445
guessTarget :: String -> Maybe Phase -> IO Target
guessTarget file (Just phase)
   = return (Target (TargetFile file (Just phase)) Nothing)
guessTarget file Nothing
446
   | isHaskellSrcFilename file
447
   = return (Target (TargetFile file Nothing) Nothing)
448 449
   | otherwise
   = do exists <- doesFileExist hs_file
450 451 452
	if exists
	   then return (Target (TargetFile hs_file Nothing) Nothing)
	   else do
453
	exists <- doesFileExist lhs_file
454 455 456
	if exists
	   then return (Target (TargetFile lhs_file Nothing) Nothing)
	   else do
Simon Marlow's avatar
Simon Marlow committed
457
	return (Target (TargetModule (mkModuleName file)) Nothing)
458
     where 
459 460
	 hs_file  = file `joinFileExt` "hs"
	 lhs_file = file `joinFileExt` "lhs"
461

462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486
-- -----------------------------------------------------------------------------
-- Extending the program scope

extendGlobalRdrScope :: Session -> [GlobalRdrElt] -> IO ()
extendGlobalRdrScope session rdrElts
    = modifySession session $ \hscEnv ->
      let global_rdr = hsc_global_rdr_env hscEnv
      in hscEnv{ hsc_global_rdr_env = foldl extendGlobalRdrEnv global_rdr rdrElts }

setGlobalRdrScope :: Session -> [GlobalRdrElt] -> IO ()
setGlobalRdrScope session rdrElts
    = modifySession session $ \hscEnv ->
      hscEnv{ hsc_global_rdr_env = foldl extendGlobalRdrEnv emptyGlobalRdrEnv rdrElts }

extendGlobalTypeScope :: Session -> [Id] -> IO ()
extendGlobalTypeScope session ids
    = modifySession session $ \hscEnv ->
      let global_type = hsc_global_type_env hscEnv
      in hscEnv{ hsc_global_type_env = extendTypeEnvWithIds global_type ids }

setGlobalTypeScope :: Session -> [Id] -> IO ()
setGlobalTypeScope session ids
    = modifySession session $ \hscEnv ->
      hscEnv{ hsc_global_type_env = extendTypeEnvWithIds emptyTypeEnv ids }

487 488 489 490
-- -----------------------------------------------------------------------------
-- Parsing Haddock comments

parseHaddockComment :: String -> Either String (HsDoc RdrName)
491 492 493 494
parseHaddockComment string = 
  case parseHaddockParagraphs (tokenise string) of
    MyLeft x  -> Left x
    MyRight x -> Right x
495

496 497
-- -----------------------------------------------------------------------------
-- Loading the program
498

499 500
-- Perform a dependency analysis starting from the current targets
-- and update the session with the new module graph.
Simon Marlow's avatar
Simon Marlow committed
501
depanal :: Session -> [ModuleName] -> Bool -> IO (Maybe ModuleGraph)
502
depanal (Session ref) excluded_mods allow_dup_roots = do
503 504 505 506 507 508 509
  hsc_env <- readIORef ref
  let
	 dflags  = hsc_dflags hsc_env
	 targets = hsc_targets hsc_env
	 old_graph = hsc_mod_graph hsc_env
	
  showPass dflags "Chasing dependencies"
510 511 512
  debugTraceMsg dflags 2 (hcat [
	     text "Chasing modules from: ",
	     hcat (punctuate comma (map pprTarget targets))])
513

514
  r <- downsweep hsc_env old_graph excluded_mods allow_dup_roots
515
  case r of
516
    Just mod_graph -> writeIORef ref hsc_env{ hsc_mod_graph = mod_graph }
517 518
    _ -> return ()
  return r
519

520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537
{-
-- | The result of load.
data LoadResult
  = LoadOk	Errors	-- ^ all specified targets were loaded successfully.
  | LoadFailed  Errors	-- ^ not all modules were loaded.

type Errors = [String]

data ErrMsg = ErrMsg { 
	errMsgSeverity  :: Severity,  -- warning, error, etc.
	errMsgSpans     :: [SrcSpan],
	errMsgShortDoc  :: Doc,
	errMsgExtraInfo :: Doc
	}
-}

data LoadHowMuch
   = LoadAllTargets
Simon Marlow's avatar
Simon Marlow committed
538 539
   | LoadUpTo ModuleName
   | LoadDependenciesOf ModuleName
540 541 542 543

-- | Try to load the program.  If a Module is supplied, then just
-- attempt to load up to this target.  If no Module is supplied,
-- then try to load all targets.
544
load :: Session -> LoadHowMuch -> IO SuccessFlag
545
load s@(Session ref) how_much
546
   = do 
547 548 549 550
	-- Dependency analysis first.  Note that this fixes the module graph:
	-- even if we don't get a fully successful upsweep, the full module
	-- graph is still retained in the Session.  We can tell which modules
	-- were successfully loaded by inspecting the Session's HPT.
551
	mb_graph <- depanal s [] False
552 553
	case mb_graph of
	   Just mod_graph -> catchingFailure $ load2 s how_much mod_graph
554
	   Nothing        -> return Failed
Ian Lynagh's avatar
Ian Lynagh committed
555
    where catchingFailure f = f `Exception.catch` \e -> do
556 557 558 559 560 561
              hsc_env <- readIORef ref
              -- trac #1565 / test ghci021:
              -- let bindings may explode if we try to use them after
              -- failing to reload
              writeIORef ref $! hsc_env{ hsc_IC = emptyInteractiveContext }
              throw e
562

Simon Marlow's avatar
Simon Marlow committed
563
load2 :: Session -> LoadHowMuch -> [ModSummary] -> IO SuccessFlag
564
load2 s@(Session ref) how_much mod_graph = do
565
        guessOutputFile s
566 567 568 569 570 571 572 573 574
	hsc_env <- readIORef ref

        let hpt1      = hsc_HPT hsc_env
        let dflags    = hsc_dflags hsc_env

	-- The "bad" boot modules are the ones for which we have
	-- B.hs-boot in the module graph, but no B.hs
	-- The downsweep should have ensured this does not happen
	-- (see msDeps)
Simon Marlow's avatar
Simon Marlow committed
575 576
        let all_home_mods = [ms_mod_name s 
			    | s <- mod_graph, not (isBootSummary s)]
577
	    bad_boot_mods = [s 	      | s <- mod_graph, isBootSummary s,
Simon Marlow's avatar
Simon Marlow committed
578
					not (ms_mod_name s `elem` all_home_mods)]
579 580 581 582 583 584 585 586
	ASSERT( null bad_boot_mods ) return ()

        -- mg2_with_srcimps drops the hi-boot nodes, returning a 
	-- graph with cycles.  Among other things, it is used for
        -- backing out partially complete cycles following a failed
        -- upsweep, and for removing from hpt all the modules
        -- not in strict downwards closure, during calls to compile.
        let mg2_with_srcimps :: [SCC ModSummary]
587
	    mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing
588

589 590 591 592 593
	-- If we can determine that any of the {-# SOURCE #-} imports
	-- are definitely unnecessary, then emit a warning.
	warnUnnecessarySourceImports dflags mg2_with_srcimps

 	let
594 595
	    -- check the stability property for each module.
	    stable_mods@(stable_obj,stable_bco)
596
	        = checkStability hpt1 mg2_with_srcimps all_home_mods
597 598 599 600 601 602 603 604 605

	    -- prune bits of the HPT which are definitely redundant now,
	    -- to save space.
	    pruned_hpt = pruneHomePackageTable hpt1 
				(flattenSCCs mg2_with_srcimps)
				stable_mods

	evaluate pruned_hpt

606 607
	debugTraceMsg dflags 2 (text "Stable obj:" <+> ppr stable_obj $$
				text "Stable BCO:" <+> ppr stable_bco)
608 609

	-- Unload any modules which are going to be re-linked this time around.
610 611
	let stable_linkables = [ linkable
			       | m <- stable_obj++stable_bco,
Simon Marlow's avatar
Simon Marlow committed
612
				 Just hmi <- [lookupUFM pruned_hpt m],
613
				 Just linkable <- [hm_linkable hmi] ]
614 615 616 617 618 619 620 621 622 623 624 625
	unload hsc_env stable_linkables

        -- We could at this point detect cycles which aren't broken by
        -- a source-import, and complain immediately, but it seems better
        -- to let upsweep_mods do this, so at least some useful work gets
        -- done before the upsweep is abandoned.
        --hPutStrLn stderr "after tsort:\n"
        --hPutStrLn stderr (showSDoc (vcat (map ppr mg2)))

        -- Now do the upsweep, calling compile for each module in
        -- turn.  Final result is version 3 of everything.

626 627 628 629 630 631
        -- Topologically sort the module graph, this time including hi-boot
	-- nodes, and possibly just including the portion of the graph
	-- reachable from the module specified in the 2nd argument to load.
	-- This graph should be cycle-free.
	-- If we're restricting the upsweep to a portion of the graph, we
	-- also want to retain everything that is still stable.
632
        let full_mg :: [SCC ModSummary]
633
	    full_mg    = topSortModuleGraph False mod_graph Nothing
634 635 636

	    maybe_top_mod = case how_much of
				LoadUpTo m           -> Just m
637
			  	LoadDependenciesOf m -> Just m
638 639
			  	_		     -> Nothing

640 641 642 643 644 645 646
	    partial_mg0 :: [SCC ModSummary]
	    partial_mg0 = topSortModuleGraph False mod_graph maybe_top_mod

	    -- LoadDependenciesOf m: we want the upsweep to stop just
	    -- short of the specified module (unless the specified module
	    -- is stable).
	    partial_mg
Simon Marlow's avatar
Simon Marlow committed
647
		| LoadDependenciesOf _mod <- how_much
648
		= ASSERT( case last partial_mg0 of 
649
			    AcyclicSCC ms -> ms_mod_name ms == _mod; _ -> False )
650 651 652 653
		  List.init partial_mg0
		| otherwise
		= partial_mg0
  
654 655 656
	    stable_mg = 
		[ AcyclicSCC ms
	        | AcyclicSCC ms <- full_mg,
Simon Marlow's avatar
Simon Marlow committed
657 658 659
		  ms_mod_name ms `elem` stable_obj++stable_bco,
		  ms_mod_name ms `notElem` [ ms_mod_name ms' | 
						AcyclicSCC ms' <- partial_mg ] ]
660 661 662

	    mg = stable_mg ++ partial_mg

663 664
	-- clean up between compilations
	let cleanup = cleanTempFilesExcept dflags
665
			  (ppFilesFromSummaries (flattenSCCs mg2_with_srcimps))
666

667 668
	debugTraceMsg dflags 2 (hang (text "Ready for upsweep") 
				   2 (ppr mg))
669 670
        (upsweep_ok, hsc_env1, modsUpswept)
           <- upsweep (hsc_env { hsc_HPT = emptyHomePackageTable })
671
			   pruned_hpt stable_mods cleanup mg
672 673 674 675 676

	-- Make modsDone be the summaries for each home module now
	-- available; this should equal the domain of hpt3.
        -- Get in in a roughly top .. bottom order (hence reverse).

677
        let modsDone = reverse modsUpswept
678 679 680 681 682 683 684 685

        -- Try and do linking in some form, depending on whether the
        -- upsweep was completely or only partially successful.

        if succeeded upsweep_ok

         then 
           -- Easy; just relink it all.
686
           do debugTraceMsg dflags 2 (text "Upsweep completely successful.")
687 688 689 690 691 692 693 694 695 696 697 698 699

	      -- Clean up after ourselves
	      cleanTempFilesExcept dflags (ppFilesFromSummaries modsDone)

	      -- Issue a warning for the confusing case where the user
	      -- said '-o foo' but we're not going to do any linking.
	      -- We attempt linking if either (a) one of the modules is
	      -- called Main, or (b) the user said -no-hs-main, indicating
	      -- that main() is going to come from somewhere else.
	      --
	      let ofile = outputFile dflags
	      let no_hs_main = dopt Opt_NoHsMain dflags
	      let 
700 701
	 	main_mod = mainModIs dflags
		a_root_is_Main = any ((==main_mod).ms_mod) mod_graph
702 703
		do_linking = a_root_is_Main || no_hs_main

704 705 706 707 708 709 710
	      when (ghcLink dflags == LinkBinary 
                    && isJust ofile && not do_linking) $
	        debugTraceMsg dflags 1 $
                    text ("Warning: output was redirected with -o, " ++
                          "but no output will be generated\n" ++
			  "because there is no " ++ 
                          moduleNameString (moduleName main_mod) ++ " module.")
711 712

	      -- link everything together
713
              linkresult <- link (ghcLink dflags) dflags do_linking (hsc_HPT hsc_env1)
714

715
	      loadFinish Succeeded linkresult ref hsc_env1
716 717 718 719 720

         else 
           -- Tricky.  We need to back out the effects of compiling any
           -- half-done cycles, both so as to clean up the top level envs
           -- and to avoid telling the interactive linker to link them.
721
           do debugTraceMsg dflags 2 (text "Upsweep partially successful.")
722 723 724 725 726 727 728 729 730 731

              let modsDone_names
                     = map ms_mod modsDone
              let mods_to_zap_names 
                     = findPartiallyCompletedCycles modsDone_names 
			  mg2_with_srcimps
              let mods_to_keep
                     = filter ((`notElem` mods_to_zap_names).ms_mod) 
			  modsDone

Simon Marlow's avatar
Simon Marlow committed
732
              let hpt4 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep) 
733
					      (hsc_HPT hsc_env1)
734 735 736 737

	      -- Clean up after ourselves
	      cleanTempFilesExcept dflags (ppFilesFromSummaries mods_to_keep)

738 739
	      -- there should be no Nothings where linkables should be, now
	      ASSERT(all (isJust.hm_linkable) 
Simon Marlow's avatar
Simon Marlow committed
740
			(eltsUFM (hsc_HPT hsc_env))) do
741
	
742
	      -- Link everything together
743
              linkresult <- link (ghcLink dflags) dflags False hpt4
744

745
	      let hsc_env4 = hsc_env1{ hsc_HPT = hpt4 }
746 747 748 749 750
	      loadFinish Failed linkresult ref hsc_env4

-- Finish up after a load.

-- If the link failed, unload everything and return.
Simon Marlow's avatar
Simon Marlow committed
751 752
loadFinish :: SuccessFlag -> SuccessFlag -> IORef HscEnv -> HscEnv -> IO SuccessFlag
loadFinish _all_ok Failed ref hsc_env
753 754 755 756 757 758 759 760 761 762
  = do unload hsc_env []
       writeIORef ref $! discardProg hsc_env
       return Failed

-- Empty the interactive context and set the module context to the topmost
-- newly loaded module, or the Prelude if none were loaded.
loadFinish all_ok Succeeded ref hsc_env
  = do writeIORef ref $! hsc_env{ hsc_IC = emptyInteractiveContext }
       return all_ok

763

764 765 766 767 768 769 770 771 772 773
-- Forget the current program, but retain the persistent info in HscEnv
discardProg :: HscEnv -> HscEnv
discardProg hsc_env
  = hsc_env { hsc_mod_graph = emptyMG, 
	      hsc_IC = emptyInteractiveContext,
	      hsc_HPT = emptyHomePackageTable }

-- used to fish out the preprocess output files for the purposes of
-- cleaning up.  The preprocessed file *might* be the same as the
-- source file, but that doesn't do any harm.
Simon Marlow's avatar
Simon Marlow committed
774
ppFilesFromSummaries :: [ModSummary] -> [FilePath]
775
ppFilesFromSummaries summaries = map ms_hspp_file summaries
776

777 778 779 780 781
-- -----------------------------------------------------------------------------
-- Check module

data CheckedModule = 
  CheckedModule { parsedSource      :: ParsedSource,
782
		  renamedSource     :: Maybe RenamedSource,
783
		  typecheckedSource :: Maybe TypecheckedSource,
784
		  checkedModuleInfo :: Maybe ModuleInfo,
785
                  coreModule        :: Maybe ModGuts
786
	        }
787 788 789 790 791
	-- ToDo: improvements that could be made here:
	--  if the module succeeded renaming but not typechecking,
	--  we can still get back the GlobalRdrEnv and exports, so
	--  perhaps the ModuleInfo should be split up into separate
	--  fields within CheckedModule.
792

793
type ParsedSource      = Located (HsModule RdrName)
794 795
type RenamedSource     = (HsGroup Name, [LImportDecl Name], Maybe [LIE Name],
                          Maybe (HsDoc Name), HaddockModInfo Name)
796 797
type TypecheckedSource = LHsBinds Id

798 799 800 801 802 803 804 805 806 807 808 809 810
-- NOTE:
--   - things that aren't in the output of the typechecker right now:
--     - the export list
--     - the imports
--     - type signatures
--     - type/data/newtype declarations
--     - class declarations
--     - instances
--   - extra things in the typechecker's output:
--     - default methods are turned into top-level decls.
--     - dictionary bindings


811
-- | This is the way to get access to parsed and typechecked source code
812
-- for a module.  'checkModule' attempts to typecheck the module.  If
813
-- successful, it returns the abstract syntax for the module.
814 815 816
-- If compileToCore is true, it also desugars the module and returns the 
-- resulting Core bindings as a component of the CheckedModule.
checkModule :: Session -> ModuleName -> Bool -> IO (Maybe CheckedModule)
Simon Marlow's avatar
Simon Marlow committed
817 818
checkModule (Session ref) mod compile_to_core
 = do
819 820
   hsc_env <- readIORef ref   
   let mg  = hsc_mod_graph hsc_env
Simon Marlow's avatar
Simon Marlow committed
821
   case [ ms | ms <- mg, ms_mod_name ms == mod ] of
822
	[] -> return Nothing
Simon Marlow's avatar
Simon Marlow committed
823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844
	(ms:_) -> checkModule_ ref ms compile_to_core False

-- | parses and typechecks a module, optionally generates Core, and also
-- loads the module into the 'Session' so that modules which depend on
-- this one may subsequently be typechecked using 'checkModule' or
-- 'checkAndLoadModule'.  If you need to check more than one module,
-- you probably want to use 'checkAndLoadModule'.  Constructing the
-- interface takes a little work, so it might be slightly slower than
-- 'checkModule'.
checkAndLoadModule :: Session -> ModSummary -> Bool -> IO (Maybe CheckedModule)
checkAndLoadModule (Session ref) ms compile_to_core
 = checkModule_ ref ms compile_to_core True

checkModule_ :: IORef HscEnv -> ModSummary -> Bool -> Bool
             -> IO (Maybe CheckedModule)
checkModule_ ref ms compile_to_core load
 = do
   let mod = ms_mod_name ms
   hsc_env0 <- readIORef ref   
   let hsc_env = hsc_env0{hsc_dflags=ms_hspp_opts ms}
   mb_parsed <- parseFile hsc_env ms
   case mb_parsed of
845
             Nothing -> return Nothing
Simon Marlow's avatar
Simon Marlow committed
846 847 848 849 850 851 852 853 854 855 856 857 858 859
             Just rdr_module -> do
               mb_typechecked <- typecheckRenameModule hsc_env ms rdr_module
               case mb_typechecked of
                 Nothing -> return (Just CheckedModule {
                                              parsedSource = rdr_module,
                                              renamedSource = Nothing,
					      typecheckedSource = Nothing,
					      checkedModuleInfo = Nothing,
                                              coreModule = Nothing })
                 Just (tcg, rn_info) -> do
                   details <- makeSimpleDetails hsc_env tcg
                   
                   let tc_binds = tcg_binds tcg
                   let rdr_env  = tcg_rdr_env tcg
860
		   let minf = ModuleInfo {
861
				minf_type_env  = md_types details,
862 863
				minf_exports   = availsToNameSet $
                                                     md_exports details,
864 865
				minf_rdr_env   = Just rdr_env,
				minf_instances = md_insts details
mnislaih's avatar
mnislaih committed
866
#ifdef GHCI
867
                               ,minf_modBreaks = emptyModBreaks 
mnislaih's avatar
mnislaih committed
868
#endif
869
			      }
Simon Marlow's avatar
Simon Marlow committed
870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886

                   mb_guts <- if compile_to_core
                                 then deSugarModule hsc_env ms tcg
                                 else return Nothing              

                   -- If we are loading this module so that we can typecheck
                   -- dependent modules, generate an interface and stuff it
                   -- all in the HomePackageTable.
                   when load $ do
		     (iface,_) <- makeSimpleIface hsc_env Nothing tcg details
                     let mod_info = HomeModInfo {
                                        hm_iface = iface,
                                        hm_details = details,
                                        hm_linkable = Nothing }
                     let hpt_new = addToUFM (hsc_HPT hsc_env) mod mod_info
                     writeIORef ref hsc_env0{ hsc_HPT = hpt_new }

887
		   return (Just (CheckedModule {
Simon Marlow's avatar
Simon Marlow committed
888 889
					parsedSource = rdr_module,
					renamedSource = rn_info,
890
					typecheckedSource = Just tc_binds,
891
					checkedModuleInfo = Just minf,
892
                                        coreModule = mb_guts }))
893

894
-- | This is the way to get access to the Core bindings corresponding
895
-- to a module. 'compileToCore' invokes 'checkModule' to parse, typecheck, and
896 897 898 899
-- desugar the module, then returns the resulting Core module (consisting of
-- the module name, type declarations, and function declarations) if
-- successful.
compileToCoreModule :: Session -> FilePath -> IO (Maybe CoreModule)
900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952