GHC.hs 55.4 KB
Newer Older
1 2
{-# LANGUAGE CPP, NondecreasingIndentation, ScopedTypeVariables #-}

3
-- -----------------------------------------------------------------------------
4
--
Gabor Greif's avatar
Gabor Greif committed
5
-- (c) The University of Glasgow, 2005-2012
6 7 8
--
-- The GHC API
--
9
-- -----------------------------------------------------------------------------
10 11

module GHC (
dterei's avatar
dterei committed
12 13 14
        -- * Initialisation
        defaultErrorHandler,
        defaultCleanupHandler,
Ian Lynagh's avatar
Ian Lynagh committed
15
        prettyPrintGhcErrors,
16 17

        -- * GHC Monad
Simon Marlow's avatar
Simon Marlow committed
18
        Ghc, GhcT, GhcMonad(..), HscEnv,
19 20
        runGhc, runGhcT, initGhcMonad,
        gcatch, gbracket, gfinally,
21 22
        printException,
        handleSourceError,
23
        needsTemplateHaskell,
24

dterei's avatar
dterei committed
25
        -- * Flags and settings
ian@well-typed.com's avatar
ian@well-typed.com committed
26
        DynFlags(..), GeneralFlag(..), Severity(..), HscTarget(..), gopt,
27
        GhcMode(..), GhcLink(..), defaultObjectTarget,
dterei's avatar
dterei committed
28
        parseDynamicFlags,
29 30 31
        getSessionDynFlags, setSessionDynFlags,
        getProgramDynFlags, setProgramDynFlags,
        getInteractiveDynFlags, setInteractiveDynFlags,
dterei's avatar
dterei committed
32 33 34 35 36 37 38 39 40 41 42 43
        parseStaticFlags,

        -- * Targets
        Target(..), TargetId(..), Phase,
        setTargets,
        getTargets,
        addTarget,
        removeTarget,
        guessTarget,
        
        -- * Loading\/compiling the program
        depanal,
Simon Marlow's avatar
Simon Marlow committed
44
        load, LoadHowMuch(..), InteractiveImport(..),
dterei's avatar
dterei committed
45
        SuccessFlag(..), succeeded, failed,
46
        defaultWarnErrLogger, WarnErrLogger,
dterei's avatar
dterei committed
47
        workingDirectoryChanged,
48
        parseModule, typecheckModule, desugarModule, loadModule,
Thomas Schilling's avatar
Thomas Schilling committed
49
        ParsedModule(..), TypecheckedModule(..), DesugaredModule(..),
dterei's avatar
dterei committed
50
        TypecheckedSource, ParsedSource, RenamedSource,   -- ditto
51
        TypecheckedMod, ParsedMod,
52 53
        moduleInfo, renamedSource, typecheckedSource,
        parsedSource, coreModule,
Simon Marlow's avatar
Simon Marlow committed
54 55 56

        -- ** Compiling to Core
        CoreModule(..),
57
        compileToCoreModule, compileToCoreSimplified,
58

dterei's avatar
dterei committed
59 60
        -- * Inspecting the module structure of the program
        ModuleGraph, ModSummary(..), ms_mod_name, ModLocation(..),
Simon Marlow's avatar
Simon Marlow committed
61 62
        getModSummary,
        getModuleGraph,
dterei's avatar
dterei committed
63 64 65 66 67 68 69 70
        isLoaded,
        topSortModuleGraph,

        -- * Inspecting modules
        ModuleInfo,
        getModuleInfo,
        modInfoTyThings,
        modInfoTopLevelScope,
71
        modInfoExports,
dterei's avatar
dterei committed
72 73 74
        modInfoInstances,
        modInfoIsExportedName,
        modInfoLookupName,
75
        modInfoIface,
76
        modInfoSafe,
dterei's avatar
dterei committed
77 78
        lookupGlobalName,
        findGlobalAnns,
79
        mkPrintUnqualifiedForModule,
80
        ModIface(..),
81
        SafeHaskellMode(..),
82

83
        -- * Querying the environment
84
        -- packageDbModules,
85

dterei's avatar
dterei committed
86 87
        -- * Printing
        PrintUnqualified, alwaysQualify,
88

dterei's avatar
dterei committed
89
        -- * Interactive evaluation
90 91 92 93 94 95 96 97 98 99 100 101

#ifdef GHCI
        -- ** Executing statements
        execStmt, ExecOptions(..), execOptions, ExecResult(..),
        resumeExec,

        -- ** Adding new declarations
        runDecls, runDeclsWithLocation,

        -- ** Get/set the current context
        parseImportDecl,
        setContext, getContext,
102
        setGHCiMonad, getGHCiMonad,
103 104
#endif
        -- ** Inspecting the current context
dterei's avatar
dterei committed
105
        getBindings, getInsts, getPrintUnqual,
dterei's avatar
dterei committed
106
        findModule, lookupModule,
107
#ifdef GHCI
108
        isModuleTrusted, moduleTrustReqs,
dterei's avatar
dterei committed
109 110
        getNamesInScope,
        getRdrNamesInScope,
111
        getGRE,
dterei's avatar
dterei committed
112 113
        moduleIsInterpreted,
        getInfo,
114 115 116 117
        showModule,
        isModuleInterpreted,

        -- ** Inspecting types and kinds
dterei's avatar
dterei committed
118 119
        exprType,
        typeKind,
120 121

        -- ** Looking up a Name
dterei's avatar
dterei committed
122
        parseName,
123 124 125 126
#endif
        lookupName,
#ifdef GHCI
        -- ** Compiling expressions
127 128
        HValue, parseExpr, compileParsedExpr,
        InteractiveEval.compileExpr, dynCompileExpr,
129 130

        -- ** Other
131
        runTcInteractive,   -- Desired by some clients (Trac #8878)
132 133 134

        -- ** The debugger
        SingleStep(..),
135 136
        Resume(resumeStmt, resumeThreadId, resumeBreakInfo, resumeSpan,
               resumeHistory, resumeHistoryIx),
137
        History(historyBreakInfo, historyEnclosingDecls), 
138
        GHC.getHistorySpan, getHistoryModule,
139
        abandon, abandonAll,
140
        getResumeContext,
pepe's avatar
pepe committed
141
        GHC.obtainTermFromId, GHC.obtainTermFromVal, reconstructType,
142
        modInfoModBreaks,
143 144
        ModBreaks(..), BreakIndex,
        BreakInfo(breakInfo_number, breakInfo_module),
145
        BreakArray, setBreakOn, setBreakOff, getBreak,
146 147
        InteractiveEval.back,
        InteractiveEval.forward,
148

149 150 151 152
        -- ** Deprecated API
        RunResult(..),
        runStmt, runStmtWithLocation,
        resume,
dterei's avatar
dterei committed
153 154
#endif

dterei's avatar
dterei committed
155
        -- * Abstract syntax elements
156

Simon Marlow's avatar
Simon Marlow committed
157
        -- ** Packages
158
        PackageKey,
Simon Marlow's avatar
Simon Marlow committed
159

dterei's avatar
dterei committed
160
        -- ** Modules
161
        Module, mkModule, pprModule, moduleName, modulePackageKey,
Simon Marlow's avatar
Simon Marlow committed
162
        ModuleName, mkModuleName, moduleNameString,
163

dterei's avatar
dterei committed
164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180
        -- ** Names
        Name, 
        isExternalName, nameModule, pprParenSymName, nameSrcSpan,
        NamedThing(..),
        RdrName(Qual,Unqual),
        
        -- ** Identifiers
        Id, idType,
        isImplicitId, isDeadBinder,
        isExportedId, isLocalId, isGlobalId,
        isRecordSelector,
        isPrimOpId, isFCallId, isClassOpId_maybe,
        isDataConWorkId, idDataCon,
        isBottomingId, isDictonaryId,
        recordSelectorFieldLabel,

        -- ** Type constructors
181
        TyCon,
dterei's avatar
dterei committed
182
        tyConTyVars, tyConDataCons, tyConArity,
183 184 185 186
        isClassTyCon, isTypeSynonymTyCon, isTypeFamilyTyCon, isNewTyCon,
        isPrimTyCon, isFunTyCon,
        isFamilyTyCon, isOpenFamilyTyCon, isOpenTypeFamilyTyCon,
        tyConClass_maybe,
Jan Stolarek's avatar
Jan Stolarek committed
187
        synTyConRhs_maybe, synTyConDefn_maybe, tyConResKind,
dterei's avatar
dterei committed
188 189 190 191 192 193 194 195 196

        -- ** Type variables
        TyVar,
        alphaTyVars,

        -- ** Data constructors
        DataCon,
        dataConSig, dataConType, dataConTyCon, dataConFieldLabels,
        dataConIsInfix, isVanillaDataCon, dataConUserType,
Simon Peyton Jones's avatar
Simon Peyton Jones committed
197
        dataConSrcBangs,
dterei's avatar
dterei committed
198 199 200 201 202 203 204 205
        StrictnessMark(..), isMarkedStrict,

        -- ** Classes
        Class, 
        classMethods, classSCTheta, classTvsFds, classATs,
        pprFundeps,

        -- ** Instances
206
        ClsInst, 
dterei's avatar
dterei committed
207
        instanceDFunId, 
208
        pprInstance, pprInstanceHdr,
209
        pprFamInst,
210

211
        FamInst,
212

dterei's avatar
dterei committed
213 214 215 216 217 218
        -- ** Types and Kinds
        Type, splitForAllTys, funResultTy, 
        pprParendType, pprTypeApp, 
        Kind,
        PredType,
        ThetaType, pprForAll, pprThetaArrowTy,
219

dterei's avatar
dterei committed
220 221
        -- ** Entities
        TyThing(..), 
222

dterei's avatar
dterei committed
223 224
        -- ** Syntax
        module HsSyn, -- ToDo: remove extraneous bits
225

dterei's avatar
dterei committed
226 227 228 229 230
        -- ** Fixities
        FixityDirection(..), 
        defaultFixity, maxPrecedence, 
        negateFixity,
        compareFixity,
231

dterei's avatar
dterei committed
232 233
        -- ** Source locations
        SrcLoc(..), RealSrcLoc, 
Ian Lynagh's avatar
Ian Lynagh committed
234
        mkSrcLoc, noSrcLoc,
dterei's avatar
dterei committed
235
        srcLocFile, srcLocLine, srcLocCol,
236
        SrcSpan(..), RealSrcSpan,
Simon Marlow's avatar
Simon Marlow committed
237
        mkSrcSpan, srcLocSpan, isGoodSrcSpan, noSrcSpan,
238
        srcSpanStart, srcSpanEnd,
dterei's avatar
dterei committed
239
        srcSpanFile, 
240 241
        srcSpanStartLine, srcSpanEndLine, 
        srcSpanStartCol, srcSpanEndCol,
242

243
        -- ** Located
dterei's avatar
dterei committed
244
        GenLocated(..), Located,
245

dterei's avatar
dterei committed
246 247
        -- *** Constructing Located
        noLoc, mkGeneralLocated,
248

dterei's avatar
dterei committed
249 250
        -- *** Deconstructing Located
        getLoc, unLoc,
251

dterei's avatar
dterei committed
252 253
        -- *** Combining and comparing Located values
        eqLocated, cmpLocated, combineLocs, addCLoc,
254 255 256
        leftmost_smallest, leftmost_largest, rightmost,
        spans, isSubspanOf,

dterei's avatar
dterei committed
257 258
        -- * Exceptions
        GhcException(..), showGhcException,
259

Jedai's avatar
Jedai committed
260 261 262 263 264
        -- * Token stream manipulations
        Token,
        getTokenStream, getRichTokenStream,
        showRichTokenStream, addSourceToTokens,

265 266 267
        -- * Pure interface to the parser
        parser,

Alan Zimmerman's avatar
Alan Zimmerman committed
268 269
        -- * API Annotations
        ApiAnns,AnnKeywordId(..),AnnotationComment(..),
Alan Zimmerman's avatar
Alan Zimmerman committed
270 271
        getAnnotation, getAndRemoveAnnotation,
        getAnnotationComments, getAndRemoveAnnotationComments,
Alan Zimmerman's avatar
Alan Zimmerman committed
272

dterei's avatar
dterei committed
273 274 275
        -- * Miscellaneous
        --sessionHscEnv,
        cyclicModuleErr,
276 277
  ) where

278 279 280
{-
 ToDo:

281
  * inline bits of HscMain here to simplify layering: hscTcExpr, hscStmt.
282 283 284 285 286 287
  * what StaticFlags should we expose, if any?
-}

#include "HsVersions.h"

#ifdef GHCI
288
import ByteCodeInstr
289
import BreakArray
290
import InteractiveEval
291
import TcRnDriver       ( runTcInteractive )
292 293
#endif

294
import PprTyThing       ( pprFamInst )
295
import HscMain
296
import GhcMake
297
import DriverPipeline   ( compileOne' )
298
import GhcMonad
299
import TcRnMonad        ( finalSafeMode, fixSafeInstances )
300
import TcRnTypes
301 302 303
import Packages
import NameSet
import RdrName
Ian Lynagh's avatar
Ian Lynagh committed
304
import qualified HsSyn -- hack as we want to reexport the whole module
305
import HsSyn
batterseapower's avatar
batterseapower committed
306
import Type     hiding( typeKind )
Jan Stolarek's avatar
Jan Stolarek committed
307
import Kind             ( tyConResKind )
dterei's avatar
dterei committed
308
import TcType           hiding( typeKind )
309
import Id
dterei's avatar
dterei committed
310
import TysPrim          ( alphaTyVars )
311 312 313 314
import TyCon
import Class
import DataCon
import Name             hiding ( varName )
315
import Avail
316
import InstEnv
317
import FamInstEnv ( FamInst )
318
import SrcLoc
319
import CoreSyn
320
import TidyPgm
321
import DriverPhases     ( Phase(..), isHaskellSrcFilename )
322 323 324
import Finder
import HscTypes
import DynFlags
325
import StaticFlags
326
import SysTools
327
import Annotations
328
import Module
329
import UniqFM
330
import Panic
331
import Platform
dterei's avatar
dterei committed
332
import Bag              ( unitBag )
333
import ErrUtils
334
import MonadUtils
335
import Util
336
import StringBuffer
337
import Outputable
338
import BasicTypes
dterei's avatar
dterei committed
339
import Maybes           ( expectJust )
340
import FastString
341
import qualified Parser
Jedai's avatar
Jedai committed
342
import Lexer
Alan Zimmerman's avatar
Alan Zimmerman committed
343
import ApiAnnotation
344

Austin Seipp's avatar
Austin Seipp committed
345
import System.Directory ( doesFileExist )
346
import Data.Maybe
dterei's avatar
dterei committed
347
import Data.List        ( find )
348
import Data.Time
349 350
import Data.Typeable    ( Typeable )
import Data.Word        ( Word8 )
351
import Control.Monad
dterei's avatar
dterei committed
352
import System.Exit      ( exitWith, ExitCode(..) )
353
import Exception
354
import Data.IORef
Ian Lynagh's avatar
Ian Lynagh committed
355
import System.FilePath
356
import System.IO
357
import Prelude hiding (init)
358

359

360
-- %************************************************************************
dterei's avatar
dterei committed
361
-- %*                                                                      *
362
--             Initialisation: exception handlers
dterei's avatar
dterei committed
363
-- %*                                                                      *
364 365
-- %************************************************************************

366 367 368 369 370

-- | 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.
371
defaultErrorHandler :: (ExceptionMonad m)
Ian Lynagh's avatar
Ian Lynagh committed
372 373
                    => FatalMessager -> FlushOut -> m a -> m a
defaultErrorHandler fm (FlushOut flushOut) inner =
374
  -- top-level exception handler: any unrecognised exception is a compiler bug.
375
  ghandle (\exception -> liftIO $ do
376
           flushOut
377
           case fromException exception of
378 379
                -- an IO exception probably isn't our fault, so don't panic
                Just (ioe :: IOException) ->
Ian Lynagh's avatar
Ian Lynagh committed
380
                  fatalErrorMsg'' fm (show ioe)
381
                _ -> case fromException exception of
382 383 384 385
                     Just UserInterrupt ->
                         -- Important to let this one propagate out so our
                         -- calling process knows we were interrupted by ^C
                         liftIO $ throwIO UserInterrupt
386
                     Just StackOverflow ->
Ian Lynagh's avatar
Ian Lynagh committed
387
                         fatalErrorMsg'' fm "stack overflow: use +RTS -K<size> to increase it"
388
                     _ -> case fromException exception of
389
                          Just (ex :: ExitCode) -> liftIO $ throwIO ex
390
                          _ ->
Ian Lynagh's avatar
Ian Lynagh committed
391 392
                              fatalErrorMsg'' fm
                                  (show (Panic (show exception)))
393
           exitWith (ExitFailure 1)
394 395
         ) $

396
  -- error messages propagated as exceptions
397
  handleGhcException
398
            (\ge -> liftIO $ do
399
                flushOut
dterei's avatar
dterei committed
400 401 402
                case ge of
                     PhaseFailed _ code -> exitWith code
                     Signal _ -> exitWith (ExitFailure 1)
Ian Lynagh's avatar
Ian Lynagh committed
403
                     _ -> do fatalErrorMsg'' fm (show ge)
dterei's avatar
dterei committed
404 405
                             exitWith (ExitFailure 1)
            ) $
406 407
  inner

408
-- | Install a default cleanup handler to remove temporary files deposited by
Gabor Greif's avatar
Gabor Greif committed
409
-- a GHC run.  This is separate from 'defaultErrorHandler', because you might
410 411
-- want to override the error handling, but still get the ordinary cleanup
-- behaviour.
412
defaultCleanupHandler :: (ExceptionMonad m) =>
413 414
                         DynFlags -> m a -> m a
defaultCleanupHandler dflags inner =
415
    -- make sure we clean up after ourselves
416
    inner `gfinally`
417 418
          (liftIO $ do
              cleanTempFiles dflags
419
              cleanTempDirs dflags
420
          )
421
          --  exceptions will be blocked while we clean the temporary files,
422 423
          -- so there shouldn't be any difficulty if we receive further
          -- signals.
424

425

426
-- %************************************************************************
dterei's avatar
dterei committed
427
-- %*                                                                      *
428
--             The Ghc Monad
dterei's avatar
dterei committed
429
-- %*                                                                      *
430
-- %************************************************************************
431 432 433 434 435 436 437 438 439 440 441 442 443 444

-- | 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
445
  ref <- newIORef (panic "empty session")
446
  let session = Session ref
447 448 449 450 451 452 453 454 455 456 457
  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.

458
#if __GLASGOW_HASKELL__ < 710
Simon Peyton Jones's avatar
Simon Peyton Jones committed
459
-- Pre-AMP change
460 461 462 463
runGhcT :: (ExceptionMonad m, Functor m) =>
#else
runGhcT :: (ExceptionMonad m) =>
#endif
464 465 466 467
           Maybe FilePath  -- ^ See argument to 'initGhcMonad'.
        -> GhcT m a        -- ^ The action to perform.
        -> m a
runGhcT mb_top_dir ghct = do
468
  ref <- liftIO $ newIORef (panic "empty session")
469
  let session = Session ref
470 471 472 473 474 475 476 477 478 479 480 481 482 483
  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
484
-- <http://hackage.haskell.org/package/ghc-paths>.
485 486

initGhcMonad :: GhcMonad m => Maybe FilePath -> m ()
487 488 489 490 491 492
initGhcMonad mb_top_dir
  = do { env <- liftIO $
                do { installSignalHandlers  -- catch ^C
                   ; initStaticOpts
                   ; mySettings <- initSysTools mb_top_dir
                   ; dflags <- initDynFlags (defaultDynFlags mySettings)
493
                   ; checkBrokenTablesNextToCode dflags
494 495 496 497 498
                   ; setUnsafeGlobalDynFlags dflags
                      -- c.f. DynFlags.parseDynamicFlagsFull, which
                      -- creates DynFlags and sets the UnsafeGlobalDynFlags
                   ; newHscEnv dflags }
       ; setSession env }
499

500 501 502 503 504 505 506 507 508 509
-- | The binutils linker on ARM emits unnecessary R_ARM_COPY relocations which
-- breaks tables-next-to-code in dynamically linked modules. This
-- check should be more selective but there is currently no released
-- version where this bug is fixed.
-- See https://sourceware.org/bugzilla/show_bug.cgi?id=16177 and
-- https://ghc.haskell.org/trac/ghc/ticket/4210#comment:29
checkBrokenTablesNextToCode :: MonadIO m => DynFlags -> m ()
checkBrokenTablesNextToCode dflags
  = do { broken <- checkBrokenTablesNextToCode' dflags
       ; when broken
510
         $ do { _ <- liftIO $ throwIO $ mkApiErr dflags invalidLdErr
511 512 513
              ; fail "unsupported linker"
              }
       }
514 515 516 517
  where
    invalidLdErr = text "Tables-next-to-code not supported on ARM" <+>
                   text "when using binutils ld (please see:" <+>
                   text "https://sourceware.org/bugzilla/show_bug.cgi?id=16177)"
518 519 520 521 522 523 524 525 526 527 528 529 530 531

checkBrokenTablesNextToCode' :: MonadIO m => DynFlags -> m Bool
checkBrokenTablesNextToCode' dflags
  | not (isARM arch)              = return False
  | WayDyn `notElem` ways dflags  = return False
  | not (tablesNextToCode dflags) = return False
  | otherwise                     = do
    linkerInfo <- liftIO $ getLinkerInfo dflags
    case linkerInfo of
      GnuLD _  -> return True
      _        -> return False
  where platform = targetPlatform dflags
        arch = platformArch platform

532 533

-- %************************************************************************
dterei's avatar
dterei committed
534
-- %*                                                                      *
535
--             Flags & settings
dterei's avatar
dterei committed
536
-- %*                                                                      *
537
-- %************************************************************************
538

539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565
-- $DynFlags
--
-- The GHC session maintains two sets of 'DynFlags':
--
--   * The "interactive" @DynFlags@, which are used for everything
--     related to interactive evaluation, including 'runStmt',
--     'runDecls', 'exprType', 'lookupName' and so on (everything
--     under \"Interactive evaluation\" in this module).
--
--   * The "program" @DynFlags@, which are used when loading
--     whole modules with 'load'
--
-- 'setInteractiveDynFlags', 'getInteractiveDynFlags' work with the
-- interactive @DynFlags@.
--
-- 'setProgramDynFlags', 'getProgramDynFlags' work with the
-- program @DynFlags@.
--
-- 'setSessionDynFlags' sets both @DynFlags@, and 'getSessionDynFlags'
-- retrieves the program @DynFlags@ (for backwards compatibility).


-- | Updates both the interactive and program 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).
566 567 568 569 570 571
--
-- 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.
--
572
setSessionDynFlags :: GhcMonad m => DynFlags -> m [PackageKey]
573
setSessionDynFlags dflags = do
574 575 576 577
  dflags' <- checkNewDynFlags dflags
  (dflags'', preload) <- liftIO $ initPackages dflags'
  modifySession $ \h -> h{ hsc_dflags = dflags''
                         , hsc_IC = (hsc_IC h){ ic_dflags = dflags'' } }
578
  invalidateModSummaryCache
579 580 581
  return preload

-- | Sets the program 'DynFlags'.
582
setProgramDynFlags :: GhcMonad m => DynFlags -> m [PackageKey]
583
setProgramDynFlags dflags = do
584 585 586
  dflags' <- checkNewDynFlags dflags
  (dflags'', preload) <- liftIO $ initPackages dflags'
  modifySession $ \h -> h{ hsc_dflags = dflags'' }
587
  invalidateModSummaryCache
588
  return preload
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
-- When changing the DynFlags, we want the changes to apply to future
-- loads, but without completely discarding the program.  But the
-- DynFlags are cached in each ModSummary in the hsc_mod_graph, so
-- after a change to DynFlags, the changes would apply to new modules
-- but not existing modules; this seems undesirable.
--
-- Furthermore, the GHC API client might expect that changing
-- log_action would affect future compilation messages, but for those
-- modules we have cached ModSummaries for, we'll continue to use the
-- old log_action.  This is definitely wrong (#7478).
--
-- Hence, we invalidate the ModSummary cache after changing the
-- DynFlags.  We do this by tweaking the date on each ModSummary, so
-- that the next downsweep will think that all the files have changed
-- and preprocess them again.  This won't necessarily cause everything
-- to be recompiled, because by the time we check whether we need to
-- recopmile a module, we'll have re-summarised the module and have a
-- correct ModSummary.
--
invalidateModSummaryCache :: GhcMonad m => m ()
invalidateModSummaryCache =
  modifySession $ \h -> h { hsc_mod_graph = map inval (hsc_mod_graph h) }
 where
  inval ms = ms { ms_hs_date = addUTCTime (-1) (ms_hs_date ms) }

615 616 617 618 619 620 621 622 623 624
-- | Returns the program 'DynFlags'.
getProgramDynFlags :: GhcMonad m => m DynFlags
getProgramDynFlags = getSessionDynFlags

-- | Set the 'DynFlags' used to evaluate interactive expressions.
-- Note: this cannot be used for changes to packages.  Use
-- 'setSessionDynFlags', or 'setProgramDynFlags' and then copy the
-- 'pkgState' into the interactive @DynFlags@.
setInteractiveDynFlags :: GhcMonad m => DynFlags -> m ()
setInteractiveDynFlags dflags = do
625 626
  dflags' <- checkNewDynFlags dflags
  modifySession $ \h -> h{ hsc_IC = (hsc_IC h) { ic_dflags = dflags' }}
627 628 629 630 631

-- | Get the 'DynFlags' used to evaluate interactive expressions.
getInteractiveDynFlags :: GhcMonad m => m DynFlags
getInteractiveDynFlags = withSession $ \h -> return (ic_dflags (hsc_IC h))

632

633
parseDynamicFlags :: MonadIO m =>
634 635 636 637
                     DynFlags -> [Located String]
                  -> m (DynFlags, [Located String], [Located String])
parseDynamicFlags = parseDynamicFlagsCmdLine

638 639 640 641
-- | Checks the set of new DynFlags for possibly erroneous option
-- combinations when invoking 'setSessionDynFlags' and friends, and if
-- found, returns a fixed copy (if possible).
checkNewDynFlags :: MonadIO m => DynFlags -> m DynFlags
Ben Gamari's avatar
Ben Gamari committed
642 643 644 645 646
checkNewDynFlags dflags = do
  -- See Note [DynFlags consistency]
  let (dflags', warnings) = makeDynFlagsConsistent dflags
  liftIO $ handleFlagWarnings dflags warnings
  return dflags'
647 648

-- %************************************************************************
dterei's avatar
dterei committed
649
-- %*                                                                      *
650
--             Setting, getting, and modifying the targets
dterei's avatar
dterei committed
651
-- %*                                                                      *
652
-- %************************************************************************
653 654 655 656 657 658

-- 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
659
-- the program\/library.  Unloading the current program is achieved by
660 661 662
-- 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 })
663

664 665 666
-- | Returns the current set of targets
getTargets :: GhcMonad m => m [Target]
getTargets = withSession (return . hsc_targets)
667

668 669 670 671
-- | Add another target.
addTarget :: GhcMonad m => Target -> m ()
addTarget target
  = modifySession (\h -> h{ hsc_targets = target : hsc_targets h })
672

673
-- | Remove a target
674 675 676
removeTarget :: GhcMonad m => TargetId -> m ()
removeTarget target_id
  = modifySession (\h -> h{ hsc_targets = filter (hsc_targets h) })
677
  where
Simon Marlow's avatar
Simon Marlow committed
678
   filter targets = [ t | t@(Target id _ _) <- targets, id /= target_id ]
679

680 681 682 683 684 685 686 687
-- | 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
688
--
689
--   - otherwise interpret the string as a module name
690
--
691
guessTarget :: GhcMonad m => String -> Maybe Phase -> m Target
Simon Marlow's avatar
Simon Marlow committed
692 693 694
guessTarget str (Just phase)
   = return (Target (TargetFile str (Just phase)) True Nothing)
guessTarget str Nothing
695
   | isHaskellSrcFilename file
Simon Marlow's avatar
Simon Marlow committed
696
   = return (target (TargetFile file Nothing))
697
   | otherwise
698
   = do exists <- liftIO $ doesFileExist hs_file
dterei's avatar
dterei committed
699 700 701 702 703 704 705
        if exists
           then return (target (TargetFile hs_file Nothing))
           else do
        exists <- liftIO $ doesFileExist lhs_file
        if exists
           then return (target (TargetFile lhs_file Nothing))
           else do
Simon Marlow's avatar
Simon Marlow committed
706 707 708
        if looksLikeModuleName file
           then return (target (TargetModule (mkModuleName file)))
           else do
Ian Lynagh's avatar
Ian Lynagh committed
709
        dflags <- getDynFlags
710
        liftIO $ throwGhcExceptionIO
Ian Lynagh's avatar
Ian Lynagh committed
711
                 (ProgramError (showSDoc dflags $
712 713
                 text "target" <+> quotes (text file) <+> 
                 text "is not a module name or a source file"))
714
     where 
Simon Marlow's avatar
Simon Marlow committed
715 716 717 718
         (file,obj_allowed)
                | '*':rest <- str = (rest, False)
                | otherwise       = (str,  True)

dterei's avatar
dterei committed
719 720
         hs_file  = file <.> "hs"
         lhs_file = file <.> "lhs"
721

Simon Marlow's avatar
Simon Marlow committed
722 723
         target tid = Target tid obj_allowed Nothing

724

725 726 727 728 729 730 731 732 733
-- | 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)
734

735 736

-- %************************************************************************
dterei's avatar
dterei committed
737
-- %*                                                                      *
738
--             Running phases one at a time
dterei's avatar
dterei committed
739
-- %*                                                                      *
740
-- %************************************************************************
741 742 743 744 745 746 747 748 749 750

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)
dterei's avatar
dterei committed
751 752 753 754 755
        -- 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.
756 757 758 759 760 761 762

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

-- | The result of successful parsing.
data ParsedModule =
  ParsedModule { pm_mod_summary   :: ModSummary
763
               , pm_parsed_source :: ParsedSource
Alan Zimmerman's avatar
Alan Zimmerman committed
764 765 766
               , pm_extra_src_files :: [FilePath]
               , pm_annotations :: ApiAnns }
               -- See Note [Api annotations] in ApiAnnotation.hs
767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788

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
789
  moduleInfo m        = tm_checked_module_info m
790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810
  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
811

812
type ParsedSource      = Located (HsModule RdrName)
813
type RenamedSource     = (HsGroup Name, [LImportDecl Name], Maybe [LIE Name],
814
                          Maybe LHsDocString)
815 816
type TypecheckedSource = LHsBinds Id

817 818 819 820 821 822 823 824 825 826 827 828
-- 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

829 830 831
-- | Return the 'ModSummary' of a module with the given name.
--
-- The module must be part of the module graph (see 'hsc_mod_graph' and
832
-- 'ModuleGraph').  If this is not the case, this function will throw a
833 834
-- 'GhcApiError'.
--
835 836
-- This function ignores boot modules and requires that there is only one
-- non-boot module with the given name.
837 838 839
getModSummary :: GhcMonad m => ModuleName -> m ModSummary
getModSummary mod = do
   mg <- liftM hsc_mod_graph getSession
840
   case [ ms | ms <- mg, ms_mod_name ms == mod, not (isBootSummary ms) ] of
841
     [] -> do dflags <- getDynFlags
842
              liftIO $ throwIO $ mkApiErr dflags (text "Module not part of module graph")
843
     [ms] -> return ms
844
     multiple -> do dflags <- getDynFlags
845
                    liftIO $ throwIO $ mkApiErr dflags (text "getModSummary is ambiguous: " <+> ppr multiple)
846 847 848 849

-- | Parse a module.
--
-- Throws a 'SourceError' on parse error.
850 851
parseModule :: GhcMonad m => ModSummary -> m ParsedModule
parseModule ms = do
852 853
   hsc_env <- getSession
   let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }
854
   hpm <- liftIO $ hscParse hsc_env_tmp ms
Alan Zimmerman's avatar
Alan Zimmerman committed
855 856 857
   return (ParsedModule ms (hpm_module hpm) (hpm_src_files hpm)
                           (hpm_annotations hpm))
               -- See Note [Api annotations] in ApiAnnotation.hs
858 859 860 861 862 863

-- | Typecheck and rename a parsed module.
--
-- Throws a 'SourceError' if either fails.
typecheckModule :: GhcMonad m => ParsedModule -> m TypecheckedModule
typecheckModule pmod = do
864
 let ms = modSummary pmod
865 866 867
 hsc_env <- getSession
 let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }
 (tc_gbl_env, rn_info)
868 869
       <- liftIO $ hscTypecheckRename hsc_env_tmp ms $
                      HsParsedModule { hpm_module = parsedSource pmod,
Alan Zimmerman's avatar
Alan Zimmerman committed
870 871
                                       hpm_src_files = pm_extra_src_files pmod,
                                       hpm_annotations = pm_annotations pmod }
872
 details <- liftIO $ makeSimpleDetails hsc_env_tmp tc_gbl_env
873
 safe    <- liftIO $ finalSafeMode (ms_hspp_opts ms) tc_gbl_env
874

875
 return $
876 877 878 879 880 881 882 883 884 885
     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),
886
           minf_instances = fixSafeInstances safe $ md_insts details,
887 888
           minf_iface     = Nothing,
           minf_safe      = safe
mnislaih's avatar
mnislaih committed
889
#ifdef GHCI
890
          ,minf_modBreaks = emptyModBreaks
mnislaih's avatar
mnislaih committed
891
#endif
892 893 894 895 896
         }}

-- | Desugar a typechecked module.
desugarModule :: GhcMonad m => TypecheckedModule -> m DesugaredModule
desugarModule tcm = do
897
 let ms = modSummary tcm
898 899 900 901 902
 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 $
903 904 905 906 907 908 909
     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
910 911 912 913 914 915 916
-- 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).
--
917 918 919 920
loadModule :: (TypecheckedMod mod, GhcMonad m) => mod -> m mod
loadModule tcm = do
   let ms = modSummary tcm
   let mod = ms_mod_name ms
921
   let loc = ms_location ms
922 923
   let (tcg, _details) = tm_internals tcm

924
   mb_linkable <- case ms_obj_date ms of
925 926 927 928 929 930
                     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
                                                
931 932 933 934
   let source_modified | isNothing mb_linkable = SourceModified
                       | otherwise             = SourceUnmodified
                       -- we can't determine stability here

935 936
   -- compile doesn't change the session
   hsc_env <- getSession
937 938 939
   mod_info <- liftIO $ compileOne' (Just tcg) Nothing
                                    hsc_env ms 1 1 Nothing mb_linkable
                                    source_modified
940 941

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

944 945

-- %************************************************************************
dterei's avatar
dterei committed
946
-- %*                                                                      *
947
--             Dealing with Core
dterei's avatar
dterei committed
948
-- %*                                                                      *
949
-- %************************************************************************
950 951 952 953 954 955 956 957 958 959

-- | 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
960 961 962
      cm_binds    :: CoreProgram,
      -- | Safe Haskell mode
      cm_safe     :: SafeHaskellMode
963 964 965
    }

instance Outputable CoreModule where
966 967 968 969
   ppr (CoreModule {cm_module = mn, cm_types = te, cm_binds = cb,
                    cm_safe = sf})
    = text "%module" <+> ppr mn <+> parens (ppr sf) <+> ppr te
      $$ vcat (map ppr cb)
970

971
-- | This is the way to get access to the Core bindings corresponding
972 973
-- to a module. 'compileToCore' parses, typechecks, and
-- desugars the module, then returns the resulting Core module (consisting of
974 975
-- the module name, type declarations, and function declarations) if
-- successful.
976
compileToCoreModule :: GhcMonad m => FilePath -> m CoreModule
977 978 979 980
compileToCoreModule = compileCore False

-- | Like compileToCoreModule, but invokes the simplifier, so
-- as to return simplified and tidied Core.
981
compileToCoreSimplified :: GhcMonad m => FilePath -> m CoreModule
982 983
compileToCoreSimplified = compileCore True

984 985
compileCore :: GhcMonad m => Bool -> FilePath -> m CoreModule
compileCore simplify fn = do
986 987
   -- First, set the target to the desired filename
   target <- guessTarget fn Nothing
988
   addTarget target
989
   _ <- load LoadAllTargets
990
   -- Then find dependencies
991
   modGraph <- depanal [] True
992
   case find ((== Just fn) . msHsFilePath) modGraph of
993 994 995 996
     Just modSummary -> do
       -- Now we have the module name;
       -- parse, typecheck and desugar the module
       mod_guts <- coreModule `fmap`
997
                      -- TODO: space leaky: call hsc* directly?
998
                      (desugarModule =<< typecheckModule =<< parseModule modSummary)
999
       liftM (gutsToCoreModule (mg_safe_haskell mod_guts)) $
1000 1001 1002 1003 1004
         if simplify
          then do
             -- If simplify is true: simplify (hscSimplify), then tidy
             -- (tidyProgram).
             hsc_env <- getSession
1005
             simpl_guts <- liftIO $ hscSimplify hsc_env mod_guts
1006 1007 1008 1009 1010 1011
             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\
1012
                           module dependency graph"
1013 1014 1015
  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.
1016 1017 1018 1019
        gutsToCoreModule :: SafeHaskellMode
                         -> Either (CgGuts, ModDetails) ModGuts
                         -> CoreModule
        gutsToCoreModule safe_mode (Left (cg, md)) = CoreModule {
1020
          cm_module = cg_module cg,
1021 1022 1023
          cm_types  = md_types md,
          cm_binds  = cg_binds cg,
          cm_safe   = safe_mode
1024
        }
1025
        gutsToCoreModule safe_mode (Right mg) = CoreModule {
1026 1027
          cm_module  = mg_module mg,
          cm_types   = typeEnvFromEntities (bindersOfBinds (mg_binds mg))
dreixel's avatar
dreixel committed
1028
                                           (mg_tcs mg)
1029
                                           (mg_fam_insts mg),
1030 1031
          cm_binds   = mg_binds mg,
          cm_safe    = safe_mode
1032
         }
1033

1034
-- %************************************************************************
dterei's avatar
dterei committed
1035
-- %*                                                                      *
1036
--             Inspecting the session
dterei's avatar
dterei committed
1037
-- %*                                                                      *
1038
-- %************************************************************************
1039

1040
-- | Get the module dependency graph.
1041 1042
getModuleGraph :: GhcMonad m => m ModuleGraph -- ToDo: DiGraph ModSummary
getModuleGraph = liftM hsc_mod_graph getSession
1043

1044 1045 1046 1047 1048 1049 1050
-- | 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 =
1051
    any (xopt Opt_TemplateHaskell . ms_hspp_opts) ms