GHC.hs 44.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

        -- * GHC Monad
        Ghc, GhcT, GhcMonad(..),
        runGhc, runGhcT, initGhcMonad,
        gcatch, gbracket, gfinally,
18 19 20
        printException,
        printExceptionAndWarnings,
        handleSourceError,
21
        needsTemplateHaskell,
22 23

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

	-- * Targets
32
	Target(..), TargetId(..), Phase,
33 34 35
	setTargets,
	getTargets,
	addTarget,
36
	removeTarget,
37 38
	guessTarget,
	
39
	-- * Loading\/compiling the program
40
	depanal,
41
	load, LoadHowMuch(..),
42
	SuccessFlag(..), succeeded, failed,
43
        defaultWarnErrLogger, WarnErrLogger,
44
	workingDirectoryChanged,
45
        parseModule, typecheckModule, desugarModule, loadModule,
Thomas Schilling's avatar
Thomas Schilling committed
46
        ParsedModule(..), TypecheckedModule(..), DesugaredModule(..),
47
	TypecheckedSource, ParsedSource, RenamedSource,   -- ditto
48
        TypecheckedMod, ParsedMod,
49 50 51
        moduleInfo, renamedSource, typecheckedSource,
        parsedSource, coreModule,
        compileToCoreModule, compileToCoreSimplified,
52
        compileCoreToObj,
53
        getModSummary,
54 55

	-- * Inspecting the module structure of the program
Simon Marlow's avatar
Simon Marlow committed
56
	ModuleGraph, ModSummary(..), ms_mod_name, ModLocation(..),
57
	getModuleGraph,
58
	isLoaded,
59 60
	topSortModuleGraph,

61 62 63 64
	-- * Inspecting modules
	ModuleInfo,
	getModuleInfo,
	modInfoTyThings,
65
	modInfoTopLevelScope,
66
        modInfoExports,
67
	modInfoInstances,
68 69
	modInfoIsExportedName,
	modInfoLookupName,
70
	lookupGlobalName,
71
	findGlobalAnns,
72
        mkPrintUnqualifiedForModule,
73

74 75 76
        -- * Querying the environment
        packageDbModules,

77 78 79
	-- * Printing
	PrintUnqualified, alwaysQualify,

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

	-- * Abstract syntax elements
118

Simon Marlow's avatar
Simon Marlow committed
119 120 121
        -- ** Packages
        PackageId,

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

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

	-- ** Type constructors
	TyCon, 
144
	tyConTyVars, tyConDataCons, tyConArity,
145
	isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon,
146
	isFamilyTyCon,
147
	synTyConDefn, synTyConType, synTyConResKind,
148

149 150 151 152
	-- ** Type variables
	TyVar,
	alphaTyVars,

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

	-- ** Classes
	Class, 
162 163
	classMethods, classSCTheta, classTvsFds,
	pprFundeps,
164

165
	-- ** Instances
166
	Instance, 
167
	instanceDFunId, pprInstance, pprInstanceHdr,
168

169
	-- ** Types and Kinds
170 171
	Type, splitForAllTys, funResultTy, 
	pprParendType, pprTypeApp, 
172
	Kind,
173
	PredType,
174
	ThetaType, pprForAll, pprThetaArrow, pprThetaArrowTy,
175 176

	-- ** Entities
177 178
	TyThing(..), 

179 180 181
	-- ** Syntax
	module HsSyn, -- ToDo: remove extraneous bits

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

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

199
        -- ** Located
Ian Lynagh's avatar
Ian Lynagh committed
200
	GenLocated(..), Located,
201 202 203 204 205 206 207 208 209 210 211 212

	-- *** Constructing Located
	noLoc, mkGeneralLocated,

	-- *** Deconstructing Located
	getLoc, unLoc,

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

213 214 215
	-- * Exceptions
	GhcException(..), showGhcException,

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

221 222 223
        -- * Pure interface to the parser
        parser,

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

229 230 231
{-
 ToDo:

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

#include "HsVersions.h"

#ifdef GHCI
239
import Linker           ( HValue )
240
import ByteCodeInstr
241
import BreakArray
242
import InteractiveEval
243 244
#endif

245
import HscMain
246 247
import GhcMake
import DriverPipeline	( compile' )
248
import GhcMonad
249
import TcRnTypes
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
256
import Coercion		( synTyConResKind )
257
import TcType		hiding( typeKind )
258
import Id
259
import TysPrim		( alphaTyVars )
260 261
import TyCon
import Class
262
-- import FunDeps
263 264
import DataCon
import Name             hiding ( varName )
265
-- import OccName		( parenSymOcc )
266
import InstEnv
267
import SrcLoc
268
import CoreSyn          ( CoreBind )
269
import TidyPgm
270
import DriverPhases     ( Phase(..), isHaskellSrcFilename )
271 272 273
import Finder
import HscTypes
import DynFlags
274
import StaticFlagParser
275
import qualified StaticFlags
276
import SysTools     ( initSysTools, cleanTempFiles, 
277
                      cleanTempDirs )
278
import Annotations
279
import Module
280
import UniqFM
281
import Panic
282
import Bag		( unitBag )
283
import ErrUtils
284
import MonadUtils
285
import Util
286
import StringBuffer
287
import Outputable
288
import BasicTypes
289
import Maybes		( expectJust )
290
import FastString
291
import qualified Parser
Jedai's avatar
Jedai committed
292
import Lexer
293

294
import System.Directory ( doesFileExist, getCurrentDirectory )
295
import Data.Maybe
296
import Data.List	( find )
297 298
import Data.Typeable    ( Typeable )
import Data.Word        ( Word8 )
299
import Control.Monad
300
import System.Exit	( exitWith, ExitCode(..) )
301
import System.Time	( getClockTime )
302
import Exception
303
import Data.IORef
Ian Lynagh's avatar
Ian Lynagh committed
304
import System.FilePath
305
import System.IO
Ian Lynagh's avatar
Ian Lynagh committed
306
import Prelude hiding (init)
307

308

309 310 311 312 313 314
-- %************************************************************************
-- %*							                   *
--             Initialisation: exception handlers
-- %*									   *
-- %************************************************************************

315 316 317 318 319

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

341
  -- error messages propagated as exceptions
342
  handleGhcException
343
            (\ge -> liftIO $ do
344
  		hFlush stdout
345
  		case ge of
346
		     PhaseFailed _ code -> exitWith code
347
		     Signal _ -> exitWith (ExitFailure 1)
348
		     _ -> do fatalErrorMsg dflags (text (show ge))
349 350 351 352
			     exitWith (ExitFailure 1)
	    ) $
  inner

353 354 355 356 357 358 359
-- | 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 =
360
    -- make sure we clean up after ourselves
361
    inner `gfinally`
362 363
          (liftIO $ do
              cleanTempFiles dflags
364
              cleanTempDirs dflags
365
          )
366
          --  exceptions will be blocked while we clean the temporary files,
367 368
          -- so there shouldn't be any difficulty if we receive further
          -- signals.
369

370

371 372 373 374 375
-- %************************************************************************
-- %*							                   *
--             The Ghc Monad
-- %*									   *
-- %************************************************************************
376 377 378 379 380 381 382 383 384 385 386 387 388 389

-- | 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
390
  ref <- newIORef (panic "empty session")
391
  let session = Session ref
392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407
  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
408
  ref <- liftIO $ newIORef (panic "empty session")
409
  let session = Session ref
410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427
  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
428
  -- catch ^C
429 430 431 432
  liftIO $ installSignalHandlers

  liftIO $ StaticFlags.initStaticOpts

433
  mySettings <- liftIO $ initSysTools mb_top_dir
434
  dflags <- liftIO $ initDynFlags (defaultDynFlags mySettings)
435
  env <- liftIO $ newHscEnv dflags
436
  setSession env
437

438 439 440 441 442 443

-- %************************************************************************
-- %*							                   *
--             Flags & settings
-- %*									   *
-- %************************************************************************
444

445 446 447 448 449 450 451 452 453 454 455
-- | 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.
--
456 457 458 459
setSessionDynFlags :: GhcMonad m => DynFlags -> m [PackageId]
setSessionDynFlags dflags = do
  (dflags', preload) <- liftIO $ initPackages dflags
  modifySession (\h -> h{ hsc_dflags = dflags' })
460
  return preload
461

462

463 464 465 466 467 468

-- %************************************************************************
-- %*							                   *
--             Setting, getting, and modifying the targets
-- %*									   *
-- %************************************************************************
469 470 471 472 473 474

-- 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
475
-- the program\/library.  Unloading the current program is achieved by
476 477 478
-- 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 })
479

480 481 482
-- | Returns the current set of targets
getTargets :: GhcMonad m => m [Target]
getTargets = withSession (return . hsc_targets)
483

484 485 486 487
-- | Add another target.
addTarget :: GhcMonad m => Target -> m ()
addTarget target
  = modifySession (\h -> h{ hsc_targets = target : hsc_targets h })
488

489
-- | Remove a target
490 491 492
removeTarget :: GhcMonad m => TargetId -> m ()
removeTarget target_id
  = modifySession (\h -> h{ hsc_targets = filter (hsc_targets h) })
493
  where
Simon Marlow's avatar
Simon Marlow committed
494
   filter targets = [ t | t@(Target id _ _) <- targets, id /= target_id ]
495

496 497 498 499 500 501 502 503
-- | 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
504
--
505
--   - otherwise interpret the string as a module name
506
--
507
guessTarget :: GhcMonad m => String -> Maybe Phase -> m Target
Simon Marlow's avatar
Simon Marlow committed
508 509 510
guessTarget str (Just phase)
   = return (Target (TargetFile str (Just phase)) True Nothing)
guessTarget str Nothing
511
   | isHaskellSrcFilename file
Simon Marlow's avatar
Simon Marlow committed
512
   = return (target (TargetFile file Nothing))
513
   | otherwise
514
   = do exists <- liftIO $ doesFileExist hs_file
515
	if exists
Simon Marlow's avatar
Simon Marlow committed
516
	   then return (target (TargetFile hs_file Nothing))
517
	   else do
518
	exists <- liftIO $ doesFileExist lhs_file
519
	if exists
Simon Marlow's avatar
Simon Marlow committed
520
	   then return (target (TargetFile lhs_file Nothing))
521
	   else do
Simon Marlow's avatar
Simon Marlow committed
522 523 524
        if looksLikeModuleName file
           then return (target (TargetModule (mkModuleName file)))
           else do
525 526
        throwGhcException
                 (ProgramError (showSDoc $
Simon Marlow's avatar
Simon Marlow committed
527 528
                 text "target" <+> quotes (text file) <+> 
                 text "is not a module name or a source file"))
529
     where 
Simon Marlow's avatar
Simon Marlow committed
530 531 532 533
         (file,obj_allowed)
                | '*':rest <- str = (rest, False)
                | otherwise       = (str,  True)

Ian Lynagh's avatar
Ian Lynagh committed
534 535
	 hs_file  = file <.> "hs"
	 lhs_file = file <.> "lhs"
536

Simon Marlow's avatar
Simon Marlow committed
537 538
         target tid = Target tid obj_allowed Nothing

539

540 541 542 543 544 545 546 547 548
-- | Inform GHC that the working directory has changed.  GHC will flush
-- its cache of module locations, since it may no longer be valid.
-- 
-- Note: Before changing the working directory make sure all threads running
-- in the same session have stopped.  If you change the working directory,
-- you should also unload the current program (set targets to empty,
-- followed by load).
workingDirectoryChanged :: GhcMonad m => m ()
workingDirectoryChanged = withSession $ (liftIO . flushFinderCaches)
549

550 551 552 553 554 555

-- %************************************************************************
-- %*							                   *
--             Running phases one at a time
-- %*									   *
-- %************************************************************************
556 557 558 559 560 561 562 563 564 565

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)
566 567 568 569
	-- 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
570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622
	--  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
623

624
type ParsedSource      = Located (HsModule RdrName)
625
type RenamedSource     = (HsGroup Name, [LImportDecl Name], Maybe [LIE Name],
626
                          Maybe LHsDocString)
627 628
type TypecheckedSource = LHsBinds Id

629 630 631 632 633 634 635 636 637 638 639 640
-- 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

641 642 643
-- | Return the 'ModSummary' of a module with the given name.
--
-- The module must be part of the module graph (see 'hsc_mod_graph' and
644
-- 'ModuleGraph').  If this is not the case, this function will throw a
645 646
-- 'GhcApiError'.
--
647 648
-- This function ignores boot modules and requires that there is only one
-- non-boot module with the given name.
649 650 651
getModSummary :: GhcMonad m => ModuleName -> m ModSummary
getModSummary mod = do
   mg <- liftM hsc_mod_graph getSession
652
   case [ ms | ms <- mg, ms_mod_name ms == mod, not (isBootSummary ms) ] of
653
     [] -> throw $ mkApiErr (text "Module not part of module graph")
654 655
     [ms] -> return ms
     multiple -> throw $ mkApiErr (text "getModSummary is ambiguous: " <+> ppr multiple)
656 657 658 659

-- | Parse a module.
--
-- Throws a 'SourceError' on parse error.
660 661
parseModule :: GhcMonad m => ModSummary -> m ParsedModule
parseModule ms = do
662 663 664
   hsc_env <- getSession
   let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }
   rdr_module <- liftIO $ hscParse hsc_env_tmp ms
665 666 667 668 669 670 671
   return (ParsedModule ms rdr_module)

-- | Typecheck and rename a parsed module.
--
-- Throws a 'SourceError' if either fails.
typecheckModule :: GhcMonad m => ParsedModule -> m TypecheckedModule
typecheckModule pmod = do
Thomas Schilling's avatar
Thomas Schilling committed
672
 let ms = modSummary pmod
673 674 675 676 677 678
 hsc_env <- getSession
 let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }
 (tc_gbl_env, rn_info)
       <- liftIO $ hscTypecheckRename hsc_env_tmp ms (parsedSource pmod)
 details <- liftIO $ makeSimpleDetails hsc_env_tmp tc_gbl_env
 return $
679 680 681 682 683 684 685 686 687 688 689
     TypecheckedModule {
       tm_internals_          = (tc_gbl_env, details),
       tm_parsed_module       = pmod,
       tm_renamed_source      = rn_info,
       tm_typechecked_source  = tcg_binds tc_gbl_env,
       tm_checked_module_info =
         ModuleInfo {
           minf_type_env  = md_types details,
           minf_exports   = availsToNameSet $ md_exports details,
           minf_rdr_env   = Just (tcg_rdr_env tc_gbl_env),
           minf_instances = md_insts details
mnislaih's avatar
mnislaih committed
690
#ifdef GHCI
691
           ,minf_modBreaks = emptyModBreaks
mnislaih's avatar
mnislaih committed
692
#endif
693 694 695 696 697
         }}

-- | Desugar a typechecked module.
desugarModule :: GhcMonad m => TypecheckedModule -> m DesugaredModule
desugarModule tcm = do
Thomas Schilling's avatar
Thomas Schilling committed
698
 let ms = modSummary tcm
699 700 701 702 703
 let (tcg, _) = tm_internals tcm
 hsc_env <- getSession
 let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }
 guts <- liftIO $ hscDesugar hsc_env_tmp ms tcg
 return $
704 705 706 707 708 709 710
     DesugaredModule {
       dm_typechecked_module = tcm,
       dm_core_module        = guts
     }

-- | Load a module.  Input doesn't need to be desugared.
--
Thomas Schilling's avatar
Thomas Schilling committed
711 712 713 714 715 716 717
-- A module must be loaded before dependent modules can be typechecked.  This
-- always includes generating a 'ModIface' and, depending on the
-- 'DynFlags.hscTarget', may also include code generation.
--
-- This function will always cause recompilation and will always overwrite
-- previous compilation results (potentially files on disk).
--
718 719 720 721
loadModule :: (TypecheckedMod mod, GhcMonad m) => mod -> m mod
loadModule tcm = do
   let ms = modSummary tcm
   let mod = ms_mod_name ms
722
   let loc = ms_location ms
723 724
   let (tcg, _details) = tm_internals tcm

725
   mb_linkable <- case ms_obj_date ms of
726 727 728 729 730 731
                     Just t | t > ms_hs_date ms  -> do
                         l <- liftIO $ findObjectLinkable (ms_mod ms) 
                                                  (ml_obj_file loc) t
                         return (Just l)
                     _otherwise -> return Nothing
                                                
732 733 734 735 736 737 738 739
   -- compile doesn't change the session
   hsc_env <- getSession
   mod_info <- liftIO $ compile' (hscNothingBackendOnly     tcg,
                                  hscInteractiveBackendOnly tcg,
                                  hscBatchBackendOnly       tcg)
                                  hsc_env ms 1 1 Nothing mb_linkable

   modifySession $ \e -> e{ hsc_HPT = addToUFM (hsc_HPT e) mod mod_info }
740
   return tcm
741

742 743 744 745 746 747

-- %************************************************************************
-- %*							                   *
--             Dealing with Core
-- %*									   *
-- %************************************************************************
748 749 750 751 752 753 754 755 756 757

-- | A CoreModule consists of just the fields of a 'ModGuts' that are needed for
-- the 'GHC.compileToCoreModule' interface.
data CoreModule
  = CoreModule {
      -- | Module name
      cm_module   :: !Module,
      -- | Type environment for types declared in this module
      cm_types    :: !TypeEnv,
      -- | Declarations
758
      cm_binds    :: [CoreBind]
759 760 761 762 763
    }

instance Outputable CoreModule where
   ppr (CoreModule {cm_module = mn, cm_types = te, cm_binds = cb}) =
      text "%module" <+> ppr mn <+> ppr te $$ vcat (map ppr cb)
764

765
-- | This is the way to get access to the Core bindings corresponding
766 767
-- to a module. 'compileToCore' parses, typechecks, and
-- desugars the module, then returns the resulting Core module (consisting of
768 769
-- the module name, type declarations, and function declarations) if
-- successful.
770
compileToCoreModule :: GhcMonad m => FilePath -> m CoreModule
771 772 773 774
compileToCoreModule = compileCore False

-- | Like compileToCoreModule, but invokes the simplifier, so
-- as to return simplified and tidied Core.
775
compileToCoreSimplified :: GhcMonad m => FilePath -> m CoreModule
776
compileToCoreSimplified = compileCore True
777
{-
778 779 780
-- | Provided for backwards-compatibility: compileToCore returns just the Core
-- bindings, but for most purposes, you probably want to call
-- compileToCoreModule.
781 782 783 784 785
compileToCore :: GhcMonad m => FilePath -> m [CoreBind]
compileToCore fn = do
   mod <- compileToCoreModule session fn
   return $ cm_binds mod
-}
786 787 788 789 790 791
-- | Takes a CoreModule and compiles the bindings therein
-- to object code. The first argument is a bool flag indicating
-- whether to run the simplifier.
-- The resulting .o, .hi, and executable files, if any, are stored in the
-- current directory, and named according to the module name.
-- This has only so far been tested with a single self-contained module.
792 793 794 795 796 797
compileCoreToObj :: GhcMonad m => Bool -> CoreModule -> m ()
compileCoreToObj simplify cm@(CoreModule{ cm_module = mName }) = do
  dflags      <- getSessionDynFlags
  currentTime <- liftIO $ getClockTime
  cwd         <- liftIO $ getCurrentDirectory
  modLocation <- liftIO $ mkHiOnlyModLocation dflags (hiSuf dflags) cwd
798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817
                   ((moduleNameSlashes . moduleName) mName)

  let modSummary = ModSummary { ms_mod = mName,
         ms_hsc_src = ExtCoreFile,
         ms_location = modLocation,
         -- By setting the object file timestamp to Nothing,
         -- we always force recompilation, which is what we
         -- want. (Thus it doesn't matter what the timestamp
         -- for the (nonexistent) source file is.)
         ms_hs_date = currentTime,
         ms_obj_date = Nothing,
         -- Only handling the single-module case for now, so no imports.
         ms_srcimps = [],
         ms_imps = [],
         -- No source file
         ms_hspp_file = "",
         ms_hspp_opts = dflags,
         ms_hspp_buf = Nothing
      }

818 819 820
  hsc_env <- getSession
  liftIO $ hscCompileCore hsc_env simplify modSummary (cm_binds cm)

821

822 823
compileCore :: GhcMonad m => Bool -> FilePath -> m CoreModule
compileCore simplify fn = do
824 825
   -- First, set the target to the desired filename
   target <- guessTarget fn Nothing
826
   addTarget target
827
   _ <- load LoadAllTargets
828
   -- Then find dependencies
829 830 831 832 833 834
   modGraph <- depanal [] True
   case find ((== fn) . msHsFilePath) modGraph of
     Just modSummary -> do
       -- Now we have the module name;
       -- parse, typecheck and desugar the module
       mod_guts <- coreModule `fmap`
Thomas Schilling's avatar
Thomas Schilling committed
835
                      -- TODO: space leaky: call hsc* directly?
836
                      (desugarModule =<< typecheckModule =<< parseModule modSummary)
837 838 839 840 841 842
       liftM gutsToCoreModule $
         if simplify
          then do
             -- If simplify is true: simplify (hscSimplify), then tidy
             -- (tidyProgram).
             hsc_env <- getSession
843
             simpl_guts <- liftIO $ hscSimplify hsc_env mod_guts
844 845 846 847 848 849
             tidy_guts <- liftIO $ tidyProgram hsc_env simpl_guts
             return $ Left tidy_guts
          else
             return $ Right mod_guts

     Nothing -> panic "compileToCoreModule: target FilePath not found in\
850
                           module dependency graph"
851 852 853 854 855 856
  where -- two versions, based on whether we simplify (thus run tidyProgram,
        -- which returns a (CgGuts, ModDetails) pair, or not (in which case
        -- we just have a ModGuts.
        gutsToCoreModule :: Either (CgGuts, ModDetails) ModGuts -> CoreModule
        gutsToCoreModule (Left (cg, md))  = CoreModule {
          cm_module = cg_module cg,    cm_types = md_types md,
857
          cm_binds = cg_binds cg
858 859 860
        }
        gutsToCoreModule (Right mg) = CoreModule {
          cm_module  = mg_module mg,                   cm_types   = mg_types mg,
861
          cm_binds   = mg_binds mg
862
         }
863

864 865 866 867 868
-- %************************************************************************
-- %*							                   *
--             Inspecting the session
-- %*									   *
-- %************************************************************************
869

870
-- | Get the module dependency graph.
871 872
getModuleGraph :: GhcMonad m => m ModuleGraph -- ToDo: DiGraph ModSummary
getModuleGraph = liftM hsc_mod_graph getSession
873

874 875 876 877 878 879 880
-- | Determines whether a set of modules requires Template Haskell.
--
-- Note that if the session's 'DynFlags' enabled Template Haskell when
-- 'depanal' was called, then each module in the returned module graph will
-- have Template Haskell enabled whether it is actually needed or not.
needsTemplateHaskell :: ModuleGraph -> Bool
needsTemplateHaskell ms =
881
    any (xopt Opt_TemplateHaskell . ms_hspp_opts) ms
882

883 884 885
-- | Return @True@ <==> module is loaded.
isLoaded :: GhcMonad m => ModuleName -> m Bool
isLoaded m = withSession $ \hsc_env ->
Simon Marlow's avatar
Simon Marlow committed
886
  return $! isJust (lookupUFM (hsc_HPT hsc_env) m)