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

module GHC (
	-- * Initialisation
	defaultErrorHandler,
	defaultCleanupHandler,
13
14
15
16
17
18
19
20

        -- * GHC Monad
        Ghc, GhcT, GhcMonad(..),
        runGhc, runGhcT, initGhcMonad,
        gcatch, gbracket, gfinally,
        clearWarnings, getWarnings, hasWarnings,
        printExceptionAndWarnings, printWarnings,
        handleSourceError,
21
22

	-- * Flags and settings
23
	DynFlags(..), DynFlag(..), Severity(..), HscTarget(..), dopt,
24
        GhcMode(..), GhcLink(..), defaultObjectTarget,
25
	parseDynamicFlags,
26
27
	getSessionDynFlags,
	setSessionDynFlags,
28
	parseStaticFlags,
29
30

	-- * Targets
31
	Target(..), TargetId(..), Phase,
32
33
34
	setTargets,
	getTargets,
	addTarget,
35
	removeTarget,
36
37
	guessTarget,
	
38
        -- * Extending the program scope 
39
40
41
42
        extendGlobalRdrScope,
        setGlobalRdrScope,
        extendGlobalTypeScope,
        setGlobalTypeScope,
43

44
	-- * Loading\/compiling the program
45
	depanal,
46
47
	load, loadWithLogger, LoadHowMuch(..), SuccessFlag(..),	-- also does depanal
        defaultWarnErrLogger, WarnErrLogger,
48
	workingDirectoryChanged,
49
50
51
        parseModule, typecheckModule, desugarModule, loadModule,
        ParsedModule, TypecheckedModule, DesugaredModule, -- all abstract
	TypecheckedSource, ParsedSource, RenamedSource,   -- ditto
52
        TypecheckedMod, ParsedMod,
53
54
55
        moduleInfo, renamedSource, typecheckedSource,
        parsedSource, coreModule,
        compileToCoreModule, compileToCoreSimplified,
56
        compileCoreToObj,
57
        getModSummary,
58

59
60
61
	-- * Parsing Haddock comments
	parseHaddockComment,

62
	-- * Inspecting the module structure of the program
Simon Marlow's avatar
Simon Marlow committed
63
	ModuleGraph, ModSummary(..), ms_mod_name, ModLocation(..),
64
	getModuleGraph,
65
	isLoaded,
66
67
	topSortModuleGraph,

68
69
70
71
	-- * Inspecting modules
	ModuleInfo,
	getModuleInfo,
	modInfoTyThings,
72
	modInfoTopLevelScope,
73
        modInfoExports,
74
	modInfoInstances,
75
76
	modInfoIsExportedName,
	modInfoLookupName,
77
	lookupGlobalName,
78
	findGlobalAnns,
79
        mkPrintUnqualifiedForModule,
80

81
82
83
	-- * Printing
	PrintUnqualified, alwaysQualify,

84
85
	-- * Interactive evaluation
	getBindings, getPrintUnqual,
Simon Marlow's avatar
Simon Marlow committed
86
        findModule,
87
88
#ifdef GHCI
	setContext, getContext,	
89
	getNamesInScope,
Simon Marlow's avatar
Simon Marlow committed
90
	getRdrNamesInScope,
91
        getGRE,
92
	moduleIsInterpreted,
93
	getInfo,
94
95
	exprType,
	typeKind,
96
	parseName,
97
	RunResult(..),  
98
99
100
101
	runStmt, SingleStep(..),
        resume,
        Resume(resumeStmt, resumeThreadId, resumeBreakInfo, resumeSpan,
               resumeHistory, resumeHistoryIx),
102
        History(historyBreakInfo, historyEnclosingDecl), 
103
        GHC.getHistorySpan, getHistoryModule,
104
105
        getResumeContext,
        abandon, abandonAll,
106
107
        InteractiveEval.back,
        InteractiveEval.forward,
108
	showModule,
109
        isModuleInterpreted,
Simon Marlow's avatar
Simon Marlow committed
110
	InteractiveEval.compileExpr, HValue, dynCompileExpr,
111
	lookupName,
pepe's avatar
pepe committed
112
        GHC.obtainTermFromId, GHC.obtainTermFromVal, reconstructType,
113
        modInfoModBreaks,
114
115
        ModBreaks(..), BreakIndex,
        BreakInfo(breakInfo_number, breakInfo_module),
116
        BreakArray, setBreakOn, setBreakOff, getBreak,
117
118
119
#endif

	-- * Abstract syntax elements
120

Simon Marlow's avatar
Simon Marlow committed
121
122
123
        -- ** Packages
        PackageId,

124
	-- ** Modules
Simon Marlow's avatar
Simon Marlow committed
125
126
	Module, mkModule, pprModule, moduleName, modulePackageId,
        ModuleName, mkModuleName, moduleNameString,
127

128
	-- ** Names
129
	Name, 
Simon Marlow's avatar
Simon Marlow committed
130
	isExternalName, nameModule, pprParenSymName, nameSrcSpan,
131
	NamedThing(..),
Simon Marlow's avatar
Simon Marlow committed
132
	RdrName(Qual,Unqual),
133
134
	
	-- ** Identifiers
135
	Id, idType,
136
	isImplicitId, isDeadBinder,
137
	isExportedId, isLocalId, isGlobalId,
138
	isRecordSelector,
139
	isPrimOpId, isFCallId, isClassOpId_maybe,
140
141
	isDataConWorkId, idDataCon,
	isBottomingId, isDictonaryId,
142
	recordSelectorFieldLabel,
143
144
145

	-- ** Type constructors
	TyCon, 
146
	tyConTyVars, tyConDataCons, tyConArity,
147
	isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon,
148
149
	isOpenTyCon,
	synTyConDefn, synTyConType, synTyConResKind,
150

151
152
153
154
	-- ** Type variables
	TyVar,
	alphaTyVars,

155
156
	-- ** Data constructors
	DataCon,
157
158
159
160
	dataConSig, dataConType, dataConTyCon, dataConFieldLabels,
	dataConIsInfix, isVanillaDataCon,
	dataConStrictMarks,  
	StrictnessMark(..), isMarkedStrict,
161
162
163

	-- ** Classes
	Class, 
164
165
	classMethods, classSCTheta, classTvsFds,
	pprFundeps,
166

167
	-- ** Instances
168
	Instance, 
169
	instanceDFunId, pprInstance, pprInstanceHdr,
170

171
	-- ** Types and Kinds
172
173
	Type, splitForAllTys, funResultTy, 
	pprParendType, pprTypeApp, 
174
	Kind,
175
176
	PredType,
	ThetaType, pprThetaArrow,
177
178

	-- ** Entities
179
180
	TyThing(..), 

181
182
183
	-- ** Syntax
	module HsSyn, -- ToDo: remove extraneous bits

184
185
186
187
188
189
190
191
	-- ** Fixities
	FixityDirection(..), 
	defaultFixity, maxPrecedence, 
	negateFixity,
	compareFixity,

	-- ** Source locations
	SrcLoc, pprDefnLoc,
Simon Marlow's avatar
Simon Marlow committed
192
        mkSrcLoc, isGoodSrcLoc, noSrcLoc,
Simon Marlow's avatar
Simon Marlow committed
193
194
	srcLocFile, srcLocLine, srcLocCol,
        SrcSpan,
Simon Marlow's avatar
Simon Marlow committed
195
        mkSrcSpan, srcLocSpan, isGoodSrcSpan, noSrcSpan,
Simon Marlow's avatar
Simon Marlow committed
196
197
198
199
        srcSpanStart, srcSpanEnd,
	srcSpanFile, 
        srcSpanStartLine, srcSpanEndLine, 
        srcSpanStartCol, srcSpanEndCol,
200

201
202
203
204
205
206
207
208
209
210
211
212
213
214
        -- ** Located
	Located(..),

	-- *** Constructing Located
	noLoc, mkGeneralLocated,

	-- *** Deconstructing Located
	getLoc, unLoc,

	-- *** Combining and comparing Located values
	eqLocated, cmpLocated, combineLocs, addCLoc,
        leftmost_smallest, leftmost_largest, rightmost,
        spans, isSubspanOf,

215
216
217
	-- * Exceptions
	GhcException(..), showGhcException,

Jedai's avatar
Jedai committed
218
219
220
221
222
        -- * Token stream manipulations
        Token,
        getTokenStream, getRichTokenStream,
        showRichTokenStream, addSourceToTokens,

223
	-- * Miscellaneous
224
	--sessionHscEnv,
225
	cyclicModuleErr,
226
227
  ) where

228
229
230
{-
 ToDo:

231
  * inline bits of HscMain here to simplify layering: hscTcExpr, hscStmt.
232
233
234
235
236
237
  * what StaticFlags should we expose, if any?
-}

#include "HsVersions.h"

#ifdef GHCI
mnislaih's avatar
mnislaih committed
238
import qualified Linker
239
import Linker           ( HValue )
240
import ByteCodeInstr
241
import BreakArray
242
243
import NameSet
import InteractiveEval
244
import TcRnDriver
245
246
#endif

247
import TcIface
Simon Marlow's avatar
Simon Marlow committed
248
import TcRnTypes        hiding (LIE)
249
import TcRnMonad        ( initIfaceCheck )
250
251
252
import Packages
import NameSet
import RdrName
Ian Lynagh's avatar
Ian Lynagh committed
253
254
import qualified HsSyn -- hack as we want to reexport the whole module
import HsSyn hiding ((<.>))
255
import Type             hiding (typeKind)
256
import TcType           hiding (typeKind)
257
import Id
258
import Var
259
import TysPrim		( alphaTyVars )
260
261
262
263
264
import TyCon
import Class
import FunDeps
import DataCon
import Name             hiding ( varName )
265
import OccName		( parenSymOcc )
266
267
268
import InstEnv		( Instance, instanceDFunId, pprInstance, pprInstanceHdr,
                          emptyInstEnv )
import FamInstEnv       ( emptyFamInstEnv )
269
import SrcLoc
270
--import CoreSyn
271
import TidyPgm
272
import DriverPipeline
273
import DriverPhases	( HscSource(..), Phase(..), isHaskellSrcFilename, startPhase )
274
import HeaderInfo
275
import Finder
Simon Marlow's avatar
Simon Marlow committed
276
import HscMain
277
278
import HscTypes
import DynFlags
279
import StaticFlagParser
280
import qualified StaticFlags
281
282
import SysTools     ( initSysTools, cleanTempFiles, cleanTempFilesExcept,
                      cleanTempDirs )
283
import Annotations
284
import Module
285
import LazyUniqFM
286
287
import UniqSet
import Unique
288
289
import FiniteMap
import Panic
290
import Digraph
291
import Bag		( unitBag, listToBag, emptyBag, isEmptyBag )
292
import ErrUtils
293
import MonadUtils
294
import Util
Jedai's avatar
Jedai committed
295
import StringBuffer	( StringBuffer, hGetStringBuffer, nextChar )
296
import Outputable
297
import BasicTypes
298
import Maybes		( expectJust, mapCatMaybes )
299
import HaddockParse
300
import HaddockLex       ( tokenise )
301
import FastString
Jedai's avatar
Jedai committed
302
import Lexer
303
304

import Control.Concurrent
305
306
import System.Directory ( getModificationTime, doesFileExist,
                          getCurrentDirectory )
307
308
import Data.Maybe
import Data.List
309
import qualified Data.List as List
310
311
import Data.Typeable    ( Typeable )
import Data.Word        ( Word8 )
312
import Control.Monad
313
import System.Exit	( exitWith, ExitCode(..) )
314
import System.Time	( ClockTime, getClockTime )
315
import Exception
316
import Data.IORef
Ian Lynagh's avatar
Ian Lynagh committed
317
import System.FilePath
318
import System.IO
319
import System.IO.Error	( try, isDoesNotExistError )
Ian Lynagh's avatar
Ian Lynagh committed
320
import Prelude hiding (init)
321

322

323
-- -----------------------------------------------------------------------------
324
-- Exception handlers
325
326
327
328
329

-- | 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.
330
defaultErrorHandler :: (ExceptionMonad m, MonadIO m) => DynFlags -> m a -> m a
331
defaultErrorHandler dflags inner =
332
  -- top-level exception handler: any unrecognised exception is a compiler bug.
333
  ghandle (\exception -> liftIO $ do
334
           hFlush stdout
335
           case fromException exception of
336
337
338
                -- an IO exception probably isn't our fault, so don't panic
                Just (ioe :: IOException) ->
                  fatalErrorMsg dflags (text (show ioe))
339
                _ -> case fromException exception of
340
341
                     Just StackOverflow ->
                         fatalErrorMsg dflags (text "stack overflow: use +RTS -K<size> to increase it")
342
                     _ -> case fromException exception of
343
344
345
346
347
                          Just (ex :: ExitCode) -> throw ex
                          _ ->
                              fatalErrorMsg dflags
                                  (text (show (Panic (show exception))))
           exitWith (ExitFailure 1)
348
349
         ) $

350
  -- error messages propagated as exceptions
351
  handleGhcException
352
            (\ge -> liftIO $ do
353
  		hFlush stdout
354
  		case ge of
355
356
		     PhaseFailed _ code -> exitWith code
		     Interrupted -> exitWith (ExitFailure 1)
357
		     _ -> do fatalErrorMsg dflags (text (show ge))
358
359
360
361
			     exitWith (ExitFailure 1)
	    ) $
  inner

362
363
364
365
366
367
368
-- | 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.
defaultCleanupHandler :: (ExceptionMonad m, MonadIO m) =>
                         DynFlags -> m a -> m a
defaultCleanupHandler dflags inner =
369
    -- make sure we clean up after ourselves
370
371
372
    inner `gonException`
          (liftIO $ do
              cleanTempFiles dflags
373
              cleanTempDirs dflags
374
          )
375
          --  exceptions will be blocked while we clean the temporary files,
376
377
          -- so there shouldn't be any difficulty if we receive further
          -- signals.
378

379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
-- | Print the error message and all warnings.  Useful inside exception
--   handlers.  Clears warnings after printing.
printExceptionAndWarnings :: GhcMonad m => SourceError -> m ()
printExceptionAndWarnings err = do
    let errs = srcErrorMessages err
    warns <- getWarnings
    dflags <- getSessionDynFlags
    if isEmptyBag errs
       -- Empty errors means we failed due to -Werror.  (Since this function
       -- takes a source error as argument, we know for sure _some_ error
       -- did indeed happen.)
       then liftIO $ do
              printBagOfWarnings dflags warns
              printBagOfErrors dflags (unitBag warnIsErrorMsg)
       else liftIO $ printBagOfErrors dflags errs
    clearWarnings

-- | Print all accumulated warnings using 'log_action'.
printWarnings :: GhcMonad m => m ()
printWarnings = do
    dflags <- getSessionDynFlags
    warns <- getWarnings
    liftIO $ printBagOfWarnings dflags warns
    clearWarnings

-- | Run function for the 'Ghc' monad.
--
-- It initialises the GHC session and warnings via 'initGhcMonad'.  Each call
-- to this function will create a new session which should not be shared among
-- several threads.
--
-- Any errors not handled inside the 'Ghc' action are propagated as IO
-- exceptions.

runGhc :: Maybe FilePath  -- ^ See argument to 'initGhcMonad'.
       -> Ghc a           -- ^ The action to perform.
       -> IO a
runGhc mb_top_dir ghc = do
  wref <- newIORef emptyBag
  ref <- newIORef undefined
  let session = Session ref wref
  flip unGhc session $ do
    initGhcMonad mb_top_dir
    ghc
  -- XXX: unregister interrupt handlers here?

-- | Run function for 'GhcT' monad transformer.
--
-- It initialises the GHC session and warnings via 'initGhcMonad'.  Each call
-- to this function will create a new session which should not be shared among
-- several threads.

runGhcT :: (ExceptionMonad m, Functor m, MonadIO m) =>
           Maybe FilePath  -- ^ See argument to 'initGhcMonad'.
        -> GhcT m a        -- ^ The action to perform.
        -> m a
runGhcT mb_top_dir ghct = do
  wref <- liftIO $ newIORef emptyBag
  ref <- liftIO $ newIORef undefined
  let session = Session ref wref
  flip unGhcT session $ do
    initGhcMonad mb_top_dir
    ghct

-- | Initialise a GHC session.
--
-- If you implement a custom 'GhcMonad' you must call this function in the
-- monad run function.  It will initialise the session variable and clear all
-- warnings.
--
-- The first argument should point to the directory where GHC's library files
-- reside.  More precisely, this should be the output of @ghc --print-libdir@
-- of the version of GHC the module using this API is compiled with.  For
-- portability, you should use the @ghc-paths@ package, available at
-- <http://hackage.haskell.org/cgi-bin/hackage-scripts/package/ghc-paths>.

initGhcMonad :: GhcMonad m => Maybe FilePath -> m ()
initGhcMonad mb_top_dir = do
457
  -- catch ^C
458
459
460
461
462
463
464
465
466
467
468
  main_thread <- liftIO $ myThreadId
  liftIO $ modifyMVar_ interruptTargetThread (return . (main_thread :))
  liftIO $ installSignalHandlers

  liftIO $ StaticFlags.initStaticOpts

  dflags0 <- liftIO $ initDynFlags defaultDynFlags
  dflags <- liftIO $ initSysTools mb_top_dir dflags0
  env <- liftIO $ newHscEnv dflags
  setSession env
  clearWarnings
469

470
471
472
473
-- -----------------------------------------------------------------------------
-- Flags & settings

-- | Grabs the DynFlags from the Session
474
475
getSessionDynFlags :: GhcMonad m => m DynFlags
getSessionDynFlags = withSession (return . hsc_dflags)
476

477
478
479
480
481
482
483
484
485
486
487
-- | 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.
--
488
489
490
491
setSessionDynFlags :: GhcMonad m => DynFlags -> m [PackageId]
setSessionDynFlags dflags = do
  (dflags', preload) <- liftIO $ initPackages dflags
  modifySession (\h -> h{ hsc_dflags = dflags' })
492
  return preload
493

494
495
-- | If there is no -o option, guess the name of target executable
-- by using top-level source file name as a base.
496
497
guessOutputFile :: GhcMonad m => m ()
guessOutputFile = modifySession $ \env ->
498
499
    let dflags = hsc_dflags env
        mod_graph = hsc_mod_graph env
Simon Marlow's avatar
Simon Marlow committed
500
        mainModuleSrcPath :: Maybe String
501
502
503
504
        mainModuleSrcPath = do
            let isMain = (== mainModIs dflags) . ms_mod
            [ms] <- return (filter isMain mod_graph)
            ml_hs_file (ms_location ms)
Simon Marlow's avatar
Simon Marlow committed
505
506
507
508
509
510
        name = fmap dropExtension mainModuleSrcPath

#if defined(mingw32_HOST_OS)
        -- we must add the .exe extention unconditionally here, otherwise
        -- when name has an extension of its own, the .exe extension will
        -- not be added by DriverPipeline.exeFileName.  See #2248
Simon Marlow's avatar
Simon Marlow committed
511
        name_exe = fmap (<.> "exe") name
Simon Marlow's avatar
Simon Marlow committed
512
513
514
#else
        name_exe = name
#endif
515
516
517
    in
    case outputFile dflags of
        Just _ -> env
Simon Marlow's avatar
Simon Marlow committed
518
        Nothing -> env { hsc_dflags = dflags { outputFile = name_exe } }
519

520
-- -----------------------------------------------------------------------------
521
-- Targets
522
523
524
525
526
527

-- 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
528
-- the program\/library.  Unloading the current program is achieved by
529
530
531
-- setting the current set of targets to be empty, followed by 'load'.
setTargets :: GhcMonad m => [Target] -> m ()
setTargets targets = modifySession (\h -> h{ hsc_targets = targets })
532

533
534
535
-- | Returns the current set of targets
getTargets :: GhcMonad m => m [Target]
getTargets = withSession (return . hsc_targets)
536

537
538
539
540
-- | Add another target.
addTarget :: GhcMonad m => Target -> m ()
addTarget target
  = modifySession (\h -> h{ hsc_targets = target : hsc_targets h })
541

542
-- | Remove a target
543
544
545
removeTarget :: GhcMonad m => TargetId -> m ()
removeTarget target_id
  = modifySession (\h -> h{ hsc_targets = filter (hsc_targets h) })
546
  where
Simon Marlow's avatar
Simon Marlow committed
547
   filter targets = [ t | t@(Target id _ _) <- targets, id /= target_id ]
548

549
550
551
552
553
554
555
556
-- | 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
557
--
558
--   - otherwise interpret the string as a module name
559
--
560
guessTarget :: GhcMonad m => String -> Maybe Phase -> m Target
Simon Marlow's avatar
Simon Marlow committed
561
562
563
guessTarget str (Just phase)
   = return (Target (TargetFile str (Just phase)) True Nothing)
guessTarget str Nothing
564
   | isHaskellSrcFilename file
Simon Marlow's avatar
Simon Marlow committed
565
   = return (target (TargetFile file Nothing))
566
   | otherwise
567
   = do exists <- liftIO $ doesFileExist hs_file
568
	if exists
Simon Marlow's avatar
Simon Marlow committed
569
	   then return (target (TargetFile hs_file Nothing))
570
	   else do
571
	exists <- liftIO $ doesFileExist lhs_file
572
	if exists
Simon Marlow's avatar
Simon Marlow committed
573
	   then return (target (TargetFile lhs_file Nothing))
574
	   else do
Simon Marlow's avatar
Simon Marlow committed
575
576
577
        if looksLikeModuleName file
           then return (target (TargetModule (mkModuleName file)))
           else do
578
579
        throwGhcException
                 (ProgramError (showSDoc $
Simon Marlow's avatar
Simon Marlow committed
580
581
                 text "target" <+> quotes (text file) <+> 
                 text "is not a module name or a source file"))
582
     where 
Simon Marlow's avatar
Simon Marlow committed
583
584
585
586
         (file,obj_allowed)
                | '*':rest <- str = (rest, False)
                | otherwise       = (str,  True)

Ian Lynagh's avatar
Ian Lynagh committed
587
588
	 hs_file  = file <.> "hs"
	 lhs_file = file <.> "lhs"
589

Simon Marlow's avatar
Simon Marlow committed
590
591
         target tid = Target tid obj_allowed Nothing

592
593
594
-- -----------------------------------------------------------------------------
-- Extending the program scope

595
596
597
extendGlobalRdrScope :: GhcMonad m => [GlobalRdrElt] -> m ()
extendGlobalRdrScope rdrElts
    = modifySession $ \hscEnv ->
598
599
600
      let global_rdr = hsc_global_rdr_env hscEnv
      in hscEnv{ hsc_global_rdr_env = foldl extendGlobalRdrEnv global_rdr rdrElts }

601
602
603
setGlobalRdrScope :: GhcMonad m => [GlobalRdrElt] -> m ()
setGlobalRdrScope rdrElts
    = modifySession $ \hscEnv ->
604
605
      hscEnv{ hsc_global_rdr_env = foldl extendGlobalRdrEnv emptyGlobalRdrEnv rdrElts }

606
607
608
extendGlobalTypeScope :: GhcMonad m => [Id] -> m ()
extendGlobalTypeScope ids
    = modifySession $ \hscEnv ->
609
610
611
      let global_type = hsc_global_type_env hscEnv
      in hscEnv{ hsc_global_type_env = extendTypeEnvWithIds global_type ids }

612
613
614
setGlobalTypeScope :: GhcMonad m => [Id] -> m ()
setGlobalTypeScope ids
    = modifySession $ \hscEnv ->
615
616
      hscEnv{ hsc_global_type_env = extendTypeEnvWithIds emptyTypeEnv ids }

617
618
619
620
-- -----------------------------------------------------------------------------
-- Parsing Haddock comments

parseHaddockComment :: String -> Either String (HsDoc RdrName)
621
622
623
624
parseHaddockComment string = 
  case parseHaddockParagraphs (tokenise string) of
    MyLeft x  -> Left x
    MyRight x -> Right x
625

626
627
-- -----------------------------------------------------------------------------
-- Loading the program
628

629
-- | Perform a dependency analysis starting from the current targets
630
-- and update the session with the new module graph.
631
632
633
634
635
636
depanal :: GhcMonad m =>
           [ModuleName]  -- ^ excluded modules
        -> Bool          -- ^ allow duplicate roots
        -> m ModuleGraph
depanal excluded_mods allow_dup_roots = do
  hsc_env <- getSession
637
638
639
640
641
  let
	 dflags  = hsc_dflags hsc_env
	 targets = hsc_targets hsc_env
	 old_graph = hsc_mod_graph hsc_env
	
642
643
  liftIO $ showPass dflags "Chasing dependencies"
  liftIO $ debugTraceMsg dflags 2 (hcat [
644
645
	     text "Chasing modules from: ",
	     hcat (punctuate comma (map pprTarget targets))])
646

647
648
649
  mod_graph <- downsweep hsc_env old_graph excluded_mods allow_dup_roots
  modifySession $ \_ -> hsc_env { hsc_mod_graph = mod_graph }
  return mod_graph
650
651
652

data LoadHowMuch
   = LoadAllTargets
Simon Marlow's avatar
Simon Marlow committed
653
654
   | LoadUpTo ModuleName
   | LoadDependenciesOf ModuleName
655

656
-- | Try to load the program.  Calls 'loadWithLogger' with the default
657
658
659
-- compiler that just immediately logs all warnings and errors.
load :: GhcMonad m => LoadHowMuch -> m SuccessFlag
load how_much =
660
661
662
663
664
665
666
667
    loadWithLogger defaultWarnErrLogger how_much

-- | A function called to log warnings and errors.
type WarnErrLogger = GhcMonad m => Maybe SourceError -> m ()

defaultWarnErrLogger :: WarnErrLogger
defaultWarnErrLogger Nothing = printWarnings
defaultWarnErrLogger (Just e) = printExceptionAndWarnings e
668

669
670
671
-- | 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.
672
--
673
674
675
676
677
-- The first argument is a function that is called after compiling each
-- module to print wanrings and errors.

loadWithLogger :: GhcMonad m => WarnErrLogger -> LoadHowMuch -> m SuccessFlag
loadWithLogger logger how_much = do
678
679
680
681
682
    -- 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.
    mod_graph <- depanal [] False
683
    load2 how_much mod_graph logger
684

685
load2 :: GhcMonad m => LoadHowMuch -> [ModSummary] -> WarnErrLogger
686
      -> m SuccessFlag
687
load2 how_much mod_graph logger = do
688
689
        guessOutputFile
	hsc_env <- getSession
690
691
692
693
694
695
696
697

        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
698
699
        let all_home_mods = [ms_mod_name s 
			    | s <- mod_graph, not (isBootSummary s)]
700
	    bad_boot_mods = [s 	      | s <- mod_graph, isBootSummary s,
Simon Marlow's avatar
Simon Marlow committed
701
					not (ms_mod_name s `elem` all_home_mods)]
702
703
	ASSERT( null bad_boot_mods ) return ()

704
705
706
707
708
709
710
711
712
        -- check that the module given in HowMuch actually exists, otherwise
        -- topSortModuleGraph will bomb later.
        let checkHowMuch (LoadUpTo m)           = checkMod m
            checkHowMuch (LoadDependenciesOf m) = checkMod m
            checkHowMuch _ = id

            checkMod m and_then
                | m `elem` all_home_mods = and_then
                | otherwise = do 
713
                        liftIO $ errorMsg dflags (text "no such module:" <+>
714
715
716
717
718
                                         quotes (ppr m))
                        return Failed

        checkHowMuch how_much $ do

719
720
721
722
723
724
        -- 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]
725
	    mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing
726

727
728
729
730
731
	-- If we can determine that any of the {-# SOURCE #-} imports
	-- are definitely unnecessary, then emit a warning.
	warnUnnecessarySourceImports dflags mg2_with_srcimps

 	let
732
733
	    -- check the stability property for each module.
	    stable_mods@(stable_obj,stable_bco)
734
	        = checkStability hpt1 mg2_with_srcimps all_home_mods
735
736
737
738
739
740
741

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

742
	liftIO $ evaluate pruned_hpt
743

744
745
746
        -- before we unload anything, make sure we don't leave an old
        -- interactive context around pointing to dead bindings.  Also,
        -- write the pruned HPT to allow the old HPT to be GC'd.
747
748
        modifySession $ \_ -> hsc_env{ hsc_IC = emptyInteractiveContext,
                                       hsc_HPT = pruned_hpt }
749

750
	liftIO $ debugTraceMsg dflags 2 (text "Stable obj:" <+> ppr stable_obj $$
751
				text "Stable BCO:" <+> ppr stable_bco)
752
753

	-- Unload any modules which are going to be re-linked this time around.
754
755
	let stable_linkables = [ linkable
			       | m <- stable_obj++stable_bco,
Simon Marlow's avatar
Simon Marlow committed
756
				 Just hmi <- [lookupUFM pruned_hpt m],
757
				 Just linkable <- [hm_linkable hmi] ]
758
	liftIO $ unload hsc_env stable_linkables
759
760
761
762
763
764
765
766
767
768
769

        -- 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.

770
771
772
773
774
775
        -- 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.
776
        let full_mg :: [SCC ModSummary]
777
	    full_mg    = topSortModuleGraph False mod_graph Nothing
778
779
780

	    maybe_top_mod = case how_much of
				LoadUpTo m           -> Just m
781
			  	LoadDependenciesOf m -> Just m
782
783
			  	_		     -> Nothing

784
785
786
787
788
789
790
	    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
791
		| LoadDependenciesOf _mod <- how_much
792
		= ASSERT( case last partial_mg0 of 
793
			    AcyclicSCC ms -> ms_mod_name ms == _mod; _ -> False )
794
795
796
797
		  List.init partial_mg0
		| otherwise
		= partial_mg0
  
798
799
800
	    stable_mg = 
		[ AcyclicSCC ms
	        | AcyclicSCC ms <- full_mg,
Simon Marlow's avatar
Simon Marlow committed
801
802
803
		  ms_mod_name ms `elem` stable_obj++stable_bco,
		  ms_mod_name ms `notElem` [ ms_mod_name ms' | 
						AcyclicSCC ms' <- partial_mg ] ]
804
805
806

	    mg = stable_mg ++ partial_mg

807
808
	-- clean up between compilations
	let cleanup = cleanTempFilesExcept dflags
809
			  (ppFilesFromSummaries (flattenSCCs mg2_with_srcimps))
810

811
	liftIO $ debugTraceMsg dflags 2 (hang (text "Ready for upsweep")
812
				   2 (ppr mg))
813
        (upsweep_ok, hsc_env1, modsUpswept)
814
           <- upsweep logger
815
816
                      (hsc_env { hsc_HPT = emptyHomePackageTable })
	              pruned_hpt stable_mods cleanup mg
817
818
819
820
821

	-- 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).

822
        let modsDone = reverse modsUpswept
823
824
825
826
827
828
829
830

        -- 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.
831
           do liftIO $ debugTraceMsg dflags 2 (text "Upsweep completely successful.")
832
833

	      -- Clean up after ourselves
834
	      liftIO $ cleanTempFilesExcept dflags (ppFilesFromSummaries modsDone)
835
836
837
838
839
840
841
842
843
844

	      -- 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 
845
846
	 	main_mod = mainModIs dflags
		a_root_is_Main = any ((==main_mod).ms_mod) mod_graph
847
848
		do_linking = a_root_is_Main || no_hs_main

849
850
	      when (ghcLink dflags == LinkBinary 
                    && isJust ofile && not do_linking) $
851
	        liftIO $ debugTraceMsg dflags 1 $
852
853
854
855
                    text ("Warning: output was redirected with -o, " ++
                          "but no output will be generated\n" ++
			  "because there is no " ++ 
                          moduleNameString (moduleName main_mod) ++ " module.")
856
857

	      -- link everything together
858
              linkresult <- liftIO $ link (ghcLink dflags) dflags do_linking (hsc_HPT hsc_env1)
859

860
	      loadFinish Succeeded linkresult hsc_env1
861
862
863
864
865

         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.
866
           do liftIO $ debugTraceMsg dflags 2 (text "Upsweep partially successful.")
867
868
869
870
871
872
873
874
875
876

              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
877
              let hpt4 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep) 
878
					      (hsc_HPT hsc_env1)
879
880

	      -- Clean up after ourselves
881
	      liftIO $ cleanTempFilesExcept dflags (ppFilesFromSummaries mods_to_keep)
882

883
884
	      -- there should be no Nothings where linkables should be, now
	      ASSERT(all (isJust.hm_linkable) 
Simon Marlow's avatar
Simon Marlow committed
885
			(eltsUFM (hsc_HPT hsc_env))) do
886
	
887
	      -- Link everything together
888
              linkresult <- liftIO $ link (ghcLink dflags) dflags False hpt4
889

890
	      let hsc_env4 = hsc_env1{ hsc_HPT = hpt4 }
891
	      loadFinish Failed linkresult hsc_env4
892
893
894
895

-- Finish up after a load.

-- If the link failed, unload everything and return.
896
897
898
899
900
901
loadFinish :: GhcMonad m =>
              SuccessFlag -> SuccessFlag -> HscEnv
           -> m SuccessFlag
loadFinish _all_ok Failed hsc_env
  = do liftIO $ unload hsc_env []
       modifySession $ \_ -> discardProg hsc_env
902
903
904
905
       return Failed

-- Empty the interactive context and set the module context to the topmost
-- newly loaded module, or the Prelude if none were loaded.
906
907
loadFinish all_ok Succeeded hsc_env
  = do modifySession $ \_ -> hsc_env{ hsc_IC = emptyInteractiveContext }
908
909
       return all_ok

910

911
912
913
914
915
916
917
918
919
920
-- 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
921
ppFilesFromSummaries :: [ModSummary] -> [FilePath]
922
ppFilesFromSummaries summaries = map ms_hspp_file summaries
923

924
-- -----------------------------------------------------------------------------
925
926
927
928
929
930
931
932
933
934

class ParsedMod m where
  modSummary   :: m -> ModSummary
  parsedSource :: m -> ParsedSource

class ParsedMod m => TypecheckedMod m where
  renamedSource     :: m -> Maybe RenamedSource
  typecheckedSource :: m -> TypecheckedSource
  moduleInfo        :: m -> ModuleInfo
  tm_internals      :: m -> (TcGblEnv, ModDetails)
935
936
937
938
	-- 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
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
	--  fields.

class TypecheckedMod m => DesugaredMod m where
  coreModule :: m -> ModGuts

-- | The result of successful parsing.
data ParsedModule =
  ParsedModule { pm_mod_summary   :: ModSummary
               , pm_parsed_source :: ParsedSource }

instance ParsedMod ParsedModule where
  modSummary m    = pm_mod_summary m
  parsedSource m = pm_parsed_source m

-- | The result of successful typechecking.  It also contains the parser
--   result.
data TypecheckedModule =
  TypecheckedModule { tm_parsed_module       :: ParsedModule
                    , tm_renamed_source      :: Maybe RenamedSource
                    , tm_typechecked_source  :: TypecheckedSource
                    , tm_checked_module_info :: ModuleInfo
                    , tm_internals_          :: (TcGblEnv, ModDetails)
                    }

instance ParsedMod TypecheckedModule where
  modSummary m   = modSummary (tm_parsed_module m)
  parsedSource m = parsedSource (tm_parsed_module m)

instance TypecheckedMod TypecheckedModule where
  renamedSource m     = tm_renamed_source m
  typecheckedSource m = tm_typechecked_source m
  moduleInfo m = tm_checked_module_info m
  tm_internals m      = tm_internals_ m

-- | The result of successful desugaring (i.e., translation to core).  Also
--  contains all the information of a typechecked module.
data DesugaredModule =
  DesugaredModule { dm_typechecked_module :: TypecheckedModule
                  , dm_core_module        :: ModGuts
             }

instance ParsedMod DesugaredModule where
  modSummary m   = modSummary (dm_typechecked_module m)
  parsedSource m = parsedSource (dm_typechecked_module m)

instance TypecheckedMod DesugaredModule where
  renamedSource m     = renamedSource (dm_typechecked_module m)
  typecheckedSource m = typecheckedSource (dm_typechecked_module m)
  moduleInfo m        = moduleInfo (dm_typechecked_module m)
  tm_internals m      = tm_internals_ (dm_typechecked_module m)

instance DesugaredMod DesugaredModule where
  coreModule m = dm_core_module m
992

993
type ParsedSource      = Located (HsModule RdrName)
994
995
type RenamedSource     = (HsGroup Name, [LImportDecl Name], Maybe [LIE Name],
                          Maybe (HsDoc Name), HaddockModInfo Name)
996
997
type TypecheckedSource = LHsBinds Id

998
999
1000
-- NOTE:
--   - things that aren't in the output of the typechecker right now:
--     - the export list