GHC.hs 58.9 KB
Newer Older
1
{-# LANGUAGE CPP, NondecreasingIndentation, ScopedTypeVariables #-}
duog's avatar
duog committed
2
{-# LANGUAGE TupleSections, NamedFieldPuns #-}
3

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

module GHC (
dterei's avatar
dterei committed
13 14 15
        -- * Initialisation
        defaultErrorHandler,
        defaultCleanupHandler,
Ian Lynagh's avatar
Ian Lynagh committed
16
        prettyPrintGhcErrors,
Sylvain HENRY's avatar
Sylvain HENRY committed
17
        withSignalHandlers,
18
        withCleanupSession,
19 20

        -- * GHC Monad
Simon Marlow's avatar
Simon Marlow committed
21
        Ghc, GhcT, GhcMonad(..), HscEnv,
22 23
        runGhc, runGhcT, initGhcMonad,
        gcatch, gbracket, gfinally,
24 25
        printException,
        handleSourceError,
26
        needsTemplateHaskellOrQQ,
27

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

        -- * Targets
        Target(..), TargetId(..), Phase,
        setTargets,
        getTargets,
        addTarget,
        removeTarget,
        guessTarget,
43

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

        -- ** Compiling to Core
        CoreModule(..),
59
        compileToCoreModule, compileToCoreSimplified,
60

dterei's avatar
dterei committed
61
        -- * Inspecting the module structure of the program
62 63
        ModuleGraph, emptyMG, mapMG, mkModuleGraph, mgModSummaries,
        mgLookupModule,
64
        ModSummary(..), ms_mod_name, ModLocation(..),
Simon Marlow's avatar
Simon Marlow committed
65 66
        getModSummary,
        getModuleGraph,
dterei's avatar
dterei committed
67 68 69 70 71 72 73 74
        isLoaded,
        topSortModuleGraph,

        -- * Inspecting modules
        ModuleInfo,
        getModuleInfo,
        modInfoTyThings,
        modInfoTopLevelScope,
75
        modInfoExports,
76
        modInfoExportsWithSelectors,
dterei's avatar
dterei committed
77 78 79
        modInfoInstances,
        modInfoIsExportedName,
        modInfoLookupName,
80
        modInfoIface,
81
        modInfoSafe,
dterei's avatar
dterei committed
82 83
        lookupGlobalName,
        findGlobalAnns,
84
        mkPrintUnqualifiedForModule,
85
        ModIface(..),
86
        SafeHaskellMode(..),
87

88
        -- * Querying the environment
89
        -- packageDbModules,
90

dterei's avatar
dterei committed
91 92
        -- * Printing
        PrintUnqualified, alwaysQualify,
93

dterei's avatar
dterei committed
94
        -- * Interactive evaluation
95 96 97 98 99 100 101 102 103 104 105

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

        -- ** Adding new declarations
        runDecls, runDeclsWithLocation,

        -- ** Get/set the current context
        parseImportDecl,
        setContext, getContext,
106
        setGHCiMonad, getGHCiMonad,
107

108
        -- ** Inspecting the current context
dterei's avatar
dterei committed
109
        getBindings, getInsts, getPrintUnqual,
dterei's avatar
dterei committed
110
        findModule, lookupModule,
111
        isModuleTrusted, moduleTrustReqs,
dterei's avatar
dterei committed
112 113
        getNamesInScope,
        getRdrNamesInScope,
114
        getGRE,
dterei's avatar
dterei committed
115 116
        moduleIsInterpreted,
        getInfo,
117
        showModule,
118
        moduleIsBootOrNotObjectLinkable,
duog's avatar
duog committed
119
        getNameToInstancesIndex,
120 121

        -- ** Inspecting types and kinds
122
        exprType, TcRnExprMode(..),
dterei's avatar
dterei committed
123
        typeKind,
124 125

        -- ** Looking up a Name
dterei's avatar
dterei committed
126
        parseName,
127
        lookupName,
128

129
        -- ** Compiling expressions
130 131
        HValue, parseExpr, compileParsedExpr,
        InteractiveEval.compileExpr, dynCompileExpr,
132 133
        ForeignHValue,
        compileExprRemote, compileParsedExprRemote,
134

135 136 137
        -- ** Docs
        getDocs, GetDocsFailure(..),

138
        -- ** Other
139
        runTcInteractive,   -- Desired by some clients (Trac #8878)
140
        isStmt, hasImport, isImport, isDecl,
141 142 143

        -- ** The debugger
        SingleStep(..),
144
        Resume(..),
145
        History(historyBreakInfo, historyEnclosingDecls),
146
        GHC.getHistorySpan, getHistoryModule,
147
        abandon, abandonAll,
148
        getResumeContext,
pepe's avatar
pepe committed
149
        GHC.obtainTermFromId, GHC.obtainTermFromVal, reconstructType,
150
        modInfoModBreaks,
151 152
        ModBreaks(..), BreakIndex,
        BreakInfo(breakInfo_number, breakInfo_module),
153 154
        InteractiveEval.back,
        InteractiveEval.forward,
155

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

Simon Marlow's avatar
Simon Marlow committed
158
        -- ** Packages
159
        UnitId,
Simon Marlow's avatar
Simon Marlow committed
160

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

dterei's avatar
dterei committed
165
        -- ** Names
166
        Name,
dterei's avatar
dterei committed
167 168 169
        isExternalName, nameModule, pprParenSymName, nameSrcSpan,
        NamedThing(..),
        RdrName(Qual,Unqual),
170

dterei's avatar
dterei committed
171 172 173 174 175 176 177 178
        -- ** Identifiers
        Id, idType,
        isImplicitId, isDeadBinder,
        isExportedId, isLocalId, isGlobalId,
        isRecordSelector,
        isPrimOpId, isFCallId, isClassOpId_maybe,
        isDataConWorkId, idDataCon,
        isBottomingId, isDictonaryId,
179
        recordSelectorTyCon,
dterei's avatar
dterei committed
180 181

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

        -- ** Type variables
        TyVar,
        alphaTyVars,

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

        -- ** Classes
202
        Class,
dterei's avatar
dterei committed
203 204 205 206
        classMethods, classSCTheta, classTvsFds, classATs,
        pprFundeps,

        -- ** Instances
207 208
        ClsInst,
        instanceDFunId,
209
        pprInstance, pprInstanceHdr,
210
        pprFamInst,
211

212
        FamInst,
213

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

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

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

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

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

245
        -- ** Located
dterei's avatar
dterei committed
246
        GenLocated(..), Located,
247

dterei's avatar
dterei committed
248 249
        -- *** Constructing Located
        noLoc, mkGeneralLocated,
250

dterei's avatar
dterei committed
251 252
        -- *** Deconstructing Located
        getLoc, unLoc,
253

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

dterei's avatar
dterei committed
259 260
        -- * Exceptions
        GhcException(..), showGhcException,
261

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

267 268 269
        -- * Pure interface to the parser
        parser,

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

dterei's avatar
dterei committed
276 277 278
        -- * Miscellaneous
        --sessionHscEnv,
        cyclicModuleErr,
279 280
  ) where

281 282 283
{-
 ToDo:

284
  * inline bits of HscMain here to simplify layering: hscTcExpr, hscStmt.
285 286 287 288
-}

#include "HsVersions.h"

289 290
import GhcPrelude hiding (init)

291
import ByteCodeTypes
292
import InteractiveEval
293
import InteractiveEvalTypes
294
import TcRnDriver       ( runTcInteractive )
295 296
import GHCi
import GHCi.RemoteTypes
297

298
import PprTyThing       ( pprFamInst )
299
import HscMain
300
import GhcMake
301
import DriverPipeline   ( compileOne' )
302
import GhcMonad
303 304
import TcRnMonad        ( finalSafeMode, fixSafeInstances, initIfaceTcRn )
import LoadIface        ( loadSysInterface )
305
import TcRnTypes
306 307 308
import Packages
import NameSet
import RdrName
309
import HsSyn
batterseapower's avatar
batterseapower committed
310
import Type     hiding( typeKind )
dterei's avatar
dterei committed
311
import TcType           hiding( typeKind )
312
import Id
dterei's avatar
dterei committed
313
import TysPrim          ( alphaTyVars )
314 315 316 317
import TyCon
import Class
import DataCon
import Name             hiding ( varName )
318
import Avail
319
import InstEnv
320
import FamInstEnv ( FamInst )
321
import SrcLoc
322
import CoreSyn
323
import TidyPgm
324
import DriverPhases     ( Phase(..), isHaskellSrcFilename )
325 326
import Finder
import HscTypes
327 328
import CmdLineParser
import DynFlags hiding (WarnReason(..))
329
import SysTools
330
import SysTools.BaseDir
331
import Annotations
332 333
import Module
import Panic
334
import Platform
335
import Bag              ( listToBag, unitBag )
336
import ErrUtils
337
import MonadUtils
338
import Util
339
import StringBuffer
340
import Outputable
341
import BasicTypes
dterei's avatar
dterei committed
342
import Maybes           ( expectJust )
343
import FastString
344
import qualified Parser
Jedai's avatar
Jedai committed
345
import Lexer
Alan Zimmerman's avatar
Alan Zimmerman committed
346
import ApiAnnotation
347
import qualified GHC.LanguageExtensions as LangExt
duog's avatar
duog committed
348 349 350 351 352 353
import NameEnv
import CoreFVs          ( orphNamesOfFamInst )
import FamInstEnv       ( famInstEnvElts )
import TcRnDriver
import Inst
import FamInst
duog's avatar
duog committed
354
import FileCleanup
355

duog's avatar
duog committed
356 357
import Data.Foldable
import qualified Data.Map.Strict as Map
duog's avatar
duog committed
358
import Data.Set (Set)
duog's avatar
duog committed
359
import qualified Data.Sequence as Seq
Austin Seipp's avatar
Austin Seipp committed
360
import System.Directory ( doesFileExist )
361
import Data.Maybe
dterei's avatar
dterei committed
362
import Data.List        ( find )
363
import Data.Time
364 365
import Data.Typeable    ( Typeable )
import Data.Word        ( Word8 )
366
import Control.Monad
dterei's avatar
dterei committed
367
import System.Exit      ( exitWith, ExitCode(..) )
368
import Exception
369
import Data.IORef
Ian Lynagh's avatar
Ian Lynagh committed
370
import System.FilePath
371

372

373
-- %************************************************************************
dterei's avatar
dterei committed
374
-- %*                                                                      *
375
--             Initialisation: exception handlers
dterei's avatar
dterei committed
376
-- %*                                                                      *
377 378
-- %************************************************************************

379 380 381 382 383

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

409
  -- error messages propagated as exceptions
410
  handleGhcException
411
            (\ge -> liftIO $ do
412
                flushOut
dterei's avatar
dterei committed
413 414
                case ge of
                     Signal _ -> exitWith (ExitFailure 1)
Ian Lynagh's avatar
Ian Lynagh committed
415
                     _ -> do fatalErrorMsg'' fm (show ge)
dterei's avatar
dterei committed
416 417
                             exitWith (ExitFailure 1)
            ) $
418 419
  inner

420 421 422 423 424 425
-- | This function is no longer necessary, cleanup is now done by
-- runGhc/runGhcT.
{-# DEPRECATED defaultCleanupHandler "Cleanup is now done by runGhc/runGhcT" #-}
defaultCleanupHandler :: (ExceptionMonad m) => DynFlags -> m a -> m a
defaultCleanupHandler _ m = m
 where _warning_suppression = m `gonException` undefined
426

427

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

-- | 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
447
  ref <- newIORef (panic "empty session")
448
  let session = Session ref
Sylvain HENRY's avatar
Sylvain HENRY committed
449
  flip unGhc session $ withSignalHandlers $ do -- catch ^C
450
    initGhcMonad mb_top_dir
451 452
    withCleanupSession ghc

453 454 455 456 457 458
-- | 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.

459
runGhcT :: ExceptionMonad m =>
460 461 462 463
           Maybe FilePath  -- ^ See argument to 'initGhcMonad'.
        -> GhcT m a        -- ^ The action to perform.
        -> m a
runGhcT mb_top_dir ghct = do
464
  ref <- liftIO $ newIORef (panic "empty session")
465
  let session = Session ref
Sylvain HENRY's avatar
Sylvain HENRY committed
466
  flip unGhcT session $ withSignalHandlers $ do -- catch ^C
467
    initGhcMonad mb_top_dir
468 469 470 471 472 473 474 475 476 477 478 479 480 481 482
    withCleanupSession ghct

withCleanupSession :: GhcMonad m => m a -> m a
withCleanupSession ghc = ghc `gfinally` cleanup
  where
   cleanup = do
      hsc_env <- getSession
      let dflags = hsc_dflags hsc_env
      liftIO $ do
          cleanTempFiles dflags
          cleanTempDirs dflags
          stopIServ hsc_env -- shut down the IServ
          --  exceptions will be blocked while we clean the temporary files,
          -- so there shouldn't be any difficulty if we receive further
          -- signals.
483 484 485 486 487 488 489 490 491 492 493

-- | 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
494
-- <http://hackage.haskell.org/package/ghc-paths>.
495 496

initGhcMonad :: GhcMonad m => Maybe FilePath -> m ()
497 498
initGhcMonad mb_top_dir
  = do { env <- liftIO $
499 500 501
                do { top_dir <- findTopDir mb_top_dir
                   ; mySettings <- initSysTools top_dir
                   ; myLlvmConfig <- initLlvmConfig top_dir
502
                   ; dflags <- initDynFlags (defaultDynFlags mySettings myLlvmConfig)
503
                   ; checkBrokenTablesNextToCode dflags
504 505 506 507 508
                   ; setUnsafeGlobalDynFlags dflags
                      -- c.f. DynFlags.parseDynamicFlagsFull, which
                      -- creates DynFlags and sets the UnsafeGlobalDynFlags
                   ; newHscEnv dflags }
       ; setSession env }
509

510 511 512 513 514 515 516 517 518 519
-- | 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
520
         $ do { _ <- liftIO $ throwIO $ mkApiErr dflags invalidLdErr
521 522 523
              ; fail "unsupported linker"
              }
       }
524 525 526 527
  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)"
528 529 530 531 532 533 534 535 536 537 538 539 540 541

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

542 543

-- %************************************************************************
dterei's avatar
dterei committed
544
-- %*                                                                      *
545
--             Flags & settings
dterei's avatar
dterei committed
546
-- %*                                                                      *
547
-- %************************************************************************
548

549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575
-- $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).
576 577 578 579 580 581
--
-- 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.
--
582
setSessionDynFlags :: GhcMonad m => DynFlags -> m [InstalledUnitId]
583
setSessionDynFlags dflags = do
584 585 586 587
  dflags' <- checkNewDynFlags dflags
  (dflags'', preload) <- liftIO $ initPackages dflags'
  modifySession $ \h -> h{ hsc_dflags = dflags''
                         , hsc_IC = (hsc_IC h){ ic_dflags = dflags'' } }
588
  invalidateModSummaryCache
589 590
  return preload

591 592 593
-- | Sets the program 'DynFlags'.  Note: this invalidates the internal
-- cached module graph, causing more work to be done the next time
-- 'load' is called.
594
setProgramDynFlags :: GhcMonad m => DynFlags -> m [InstalledUnitId]
595 596 597 598 599
setProgramDynFlags dflags = setProgramDynFlags_ True dflags

-- | Set the action taken when the compiler produces a message.  This
-- can also be accomplished using 'setProgramDynFlags', but using
-- 'setLogAction' avoids invalidating the cached module graph.
600 601
setLogAction :: GhcMonad m => LogAction -> m ()
setLogAction action = do
602 603
  dflags' <- getProgramDynFlags
  void $ setProgramDynFlags_ False $
604
    dflags' { log_action = action }
605 606 607

setProgramDynFlags_ :: GhcMonad m => Bool -> DynFlags -> m [InstalledUnitId]
setProgramDynFlags_ invalidate_needed dflags = do
608
  dflags' <- checkNewDynFlags dflags
609 610 611 612 613
  dflags_prev <- getProgramDynFlags
  (dflags'', preload) <-
    if (packageFlagsChanged dflags_prev dflags')
       then liftIO $ initPackages dflags'
       else return (dflags', [])
614
  modifySession $ \h -> h{ hsc_dflags = dflags'' }
615
  when invalidate_needed $ invalidateModSummaryCache
616
  return preload
617

618

619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639
-- 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 =
640
  modifySession $ \h -> h { hsc_mod_graph = mapMG inval (hsc_mod_graph h) }
641 642 643
 where
  inval ms = ms { ms_hs_date = addUTCTime (-1) (ms_hs_date ms) }

644 645 646 647 648 649 650 651 652 653
-- | 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
654
  dflags' <- checkNewDynFlags dflags
655 656
  dflags'' <- checkNewInteractiveDynFlags dflags'
  modifySession $ \h -> h{ hsc_IC = (hsc_IC h) { ic_dflags = dflags'' }}
657 658 659 660 661

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

662

663
parseDynamicFlags :: MonadIO m =>
664
                     DynFlags -> [Located String]
665
                  -> m (DynFlags, [Located String], [Warn])
666 667
parseDynamicFlags = parseDynamicFlagsCmdLine

668 669 670 671
-- | 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
672 673 674
checkNewDynFlags dflags = do
  -- See Note [DynFlags consistency]
  let (dflags', warnings) = makeDynFlagsConsistent dflags
675
  liftIO $ handleFlagWarnings dflags (map (Warn NoReason) warnings)
Ben Gamari's avatar
Ben Gamari committed
676
  return dflags'
677

678 679 680 681 682 683 684 685 686 687 688 689
checkNewInteractiveDynFlags :: MonadIO m => DynFlags -> m DynFlags
checkNewInteractiveDynFlags dflags0 = do
  dflags1 <-
      if xopt LangExt.StaticPointers dflags0
      then do liftIO $ printOrThrowWarnings dflags0 $ listToBag
                [mkPlainWarnMsg dflags0 interactiveSrcSpan
                 $ text "StaticPointers is not supported in GHCi interactive expressions."]
              return $ xopt_unset dflags0 LangExt.StaticPointers
      else return dflags0
  return dflags1


690
-- %************************************************************************
dterei's avatar
dterei committed
691
-- %*                                                                      *
692
--             Setting, getting, and modifying the targets
dterei's avatar
dterei committed
693
-- %*                                                                      *
694
-- %************************************************************************
695 696 697 698 699 700

-- 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
701
-- the program\/library.  Unloading the current program is achieved by
702 703 704
-- 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 })
705

706 707 708
-- | Returns the current set of targets
getTargets :: GhcMonad m => m [Target]
getTargets = withSession (return . hsc_targets)
709

710 711 712 713
-- | Add another target.
addTarget :: GhcMonad m => Target -> m ()
addTarget target
  = modifySession (\h -> h{ hsc_targets = target : hsc_targets h })
714

715
-- | Remove a target
716 717 718
removeTarget :: GhcMonad m => TargetId -> m ()
removeTarget target_id
  = modifySession (\h -> h{ hsc_targets = filter (hsc_targets h) })
719
  where
Simon Marlow's avatar
Simon Marlow committed
720
   filter targets = [ t | t@(Target id _ _) <- targets, id /= target_id ]
721

722 723 724 725 726 727 728 729
-- | 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
730
--
731
--   - otherwise interpret the string as a module name
732
--
733
guessTarget :: GhcMonad m => String -> Maybe Phase -> m Target
Simon Marlow's avatar
Simon Marlow committed
734 735 736
guessTarget str (Just phase)
   = return (Target (TargetFile str (Just phase)) True Nothing)
guessTarget str Nothing
737
   | isHaskellSrcFilename file
Simon Marlow's avatar
Simon Marlow committed
738
   = return (target (TargetFile file Nothing))
739
   | otherwise
740
   = do exists <- liftIO $ doesFileExist hs_file
dterei's avatar
dterei committed
741 742 743 744 745 746 747
        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
748 749 750
        if looksLikeModuleName file
           then return (target (TargetModule (mkModuleName file)))
           else do
Ian Lynagh's avatar
Ian Lynagh committed
751
        dflags <- getDynFlags
752
        liftIO $ throwGhcExceptionIO
Ian Lynagh's avatar
Ian Lynagh committed
753
                 (ProgramError (showSDoc dflags $
754
                 text "target" <+> quotes (text file) <+>
755
                 text "is not a module name or a source file"))
756
     where
Simon Marlow's avatar
Simon Marlow committed
757 758 759 760
         (file,obj_allowed)
                | '*':rest <- str = (rest, False)
                | otherwise       = (str,  True)

dterei's avatar
dterei committed
761 762
         hs_file  = file <.> "hs"
         lhs_file = file <.> "lhs"
763

Simon Marlow's avatar
Simon Marlow committed
764 765
         target tid = Target tid obj_allowed Nothing

766

767 768
-- | Inform GHC that the working directory has changed.  GHC will flush
-- its cache of module locations, since it may no longer be valid.
769
--
770 771 772 773 774 775
-- 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)
776

777 778

-- %************************************************************************
dterei's avatar
dterei committed
779
-- %*                                                                      *
780
--             Running phases one at a time
dterei's avatar
dterei committed
781
-- %*                                                                      *
782
-- %************************************************************************
783 784 785 786 787 788 789 790 791 792

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
793 794 795 796 797
        -- 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.
798 799 800 801 802 803 804

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

-- | The result of successful parsing.
data ParsedModule =
  ParsedModule { pm_mod_summary   :: ModSummary
805
               , pm_parsed_source :: ParsedSource
Alan Zimmerman's avatar
Alan Zimmerman committed
806 807 808
               , pm_extra_src_files :: [FilePath]
               , pm_annotations :: ApiAnns }
               -- See Note [Api annotations] in ApiAnnotation.hs
809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830

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
831
  moduleInfo m        = tm_checked_module_info m
832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852
  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
853

854
type ParsedSource      = Located (HsModule GhcPs)
855
type RenamedSource     = (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [(LIE GhcRn, Avails)],
856
                          Maybe LHsDocString)
857
type TypecheckedSource = LHsBinds GhcTc
858

859 860 861 862 863 864 865 866 867 868 869 870
-- 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

871 872 873
-- | Return the 'ModSummary' of a module with the given name.
--
-- The module must be part of the module graph (see 'hsc_mod_graph' and
874
-- 'ModuleGraph').  If this is not the case, this function will throw a
875 876
-- 'GhcApiError'.
--
877 878
-- This function ignores boot modules and requires that there is only one
-- non-boot module with the given name.
879 880 881
getModSummary :: GhcMonad m => ModuleName -> m ModSummary
getModSummary mod = do
   mg <- liftM hsc_mod_graph getSession
882 883 884 885
   let mods_by_name = [ ms | ms <- mgModSummaries mg
                      , ms_mod_name ms == mod
                      , not (isBootSummary ms) ]
   case mods_by_name of
886
     [] -> do dflags <- getDynFlags
887
              liftIO $ throwIO $ mkApiErr dflags (text "Module not part of module graph")
888
     [ms] -> return ms
889
     multiple -> do dflags <- getDynFlags
890
                    liftIO $ throwIO $ mkApiErr dflags (text "getModSummary is ambiguous: " <+> ppr multiple)
891 892 893 894

-- | Parse a module.
--
-- Throws a 'SourceError' on parse error.
895 896
parseModule :: GhcMonad m => ModSummary -> m ParsedModule
parseModule ms = do
897 898
   hsc_env <- getSession
   let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }
899
   hpm <- liftIO $ hscParse hsc_env_tmp ms
Alan Zimmerman's avatar
Alan Zimmerman committed
900 901 902
   return (ParsedModule ms (hpm_module hpm) (hpm_src_files hpm)
                           (hpm_annotations hpm))
               -- See Note [Api annotations] in ApiAnnotation.hs
903 904 905 906 907 908

-- | Typecheck and rename a parsed module.
--
-- Throws a 'SourceError' if either fails.
typecheckModule :: GhcMonad m => ParsedModule -> m TypecheckedModule
typecheckModule pmod = do
909
 let ms = modSummary pmod
910 911 912
 hsc_env <- getSession
 let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }
 (tc_gbl_env, rn_info)
913 914
       <- liftIO $ hscTypecheckRename hsc_env_tmp ms $
                      HsParsedModule { hpm_module = parsedSource pmod,
Alan Zimmerman's avatar
Alan Zimmerman committed
915 916
                                       hpm_src_files = pm_extra_src_files pmod,
                                       hpm_annotations = pm_annotations pmod }
917
 details <- liftIO $ makeSimpleDetails hsc_env_tmp tc_gbl_env
918
 safe    <- liftIO $ finalSafeMode (ms_hspp_opts ms) tc_gbl_env
919

920
 return $
921 922 923 924 925 926 927 928
     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,
929
           minf_exports   = md_exports details,
930
           minf_rdr_env   = Just (tcg_rdr_env tc_gbl_env),
931
           minf_instances = fixSafeInstances safe $ md_insts details,
932
           minf_iface     = Nothing,
933 934
           minf_safe      = safe,
           minf_modBreaks = emptyModBreaks
935 936 937 938 939
         }}

-- | Desugar a typechecked module.
desugarModule :: GhcMonad m => TypecheckedModule -> m DesugaredModule
desugarModule tcm = do
940
 let ms = modSummary tcm
941 942 943 944 945
 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 $
946 947 948 949 950 951 952
     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
953 954 955 956 957 958 959
-- 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).
--
960 961 962 963
loadModule :: (TypecheckedMod mod, GhcMonad m) => mod -> m mod
loadModule tcm = do
   let ms = modSummary tcm
   let mod = ms_mod_name ms
964
   let loc = ms_location ms
965 966
   let (tcg, _details) = tm_internals tcm

967
   mb_linkable <- case ms_obj_date ms of
968
                     Just t | t > ms_hs_date ms  -> do
969
                         l <- liftIO $ findObjectLinkable (ms_mod ms)
970 971 972
                                                  (ml_obj_file loc) t
                         return (Just l)
                     _otherwise -> return Nothing
973

974 975 976 977
   let source_modified | isNothing mb_linkable = SourceModified
                       | otherwise             = SourceUnmodified
                       -- we can't determine stability here

978 979
   -- compile doesn't change the session
   hsc_env <- getSession
980 981 982
   mod_info <- liftIO $ compileOne' (Just tcg) Nothing
                                    hsc_env ms 1 1 Nothing mb_linkable
                                    source_modified
983

niteria's avatar
niteria committed
984
   modifySession $ \e -> e{ hsc_HPT = addToHpt (hsc_HPT e) mod mod_info }
985
   return tcm
986

987 988

-- %************************************************************************
dterei's avatar
dterei committed
989
-- %*                                                                      *
990
--             Dealing with Core
dterei's avatar
dterei committed
991
-- %*                                                                      *
992
-- %************************************************************************
993 994 995 996 997 998 999 1000 1001 1002

-- | 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
1003 1004 1005
      cm_binds    :: CoreProgram,
      -- | Safe Haskell mode
      cm_safe     :: SafeHaskellMode
1006 1007 1008
    }

instance Outputable CoreModule where
1009 1010 1011 1012
   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)
1013

1014
-- | This is the way to get access to the Core bindings corresponding
1015 1016
-- to a module. 'compileToCore' parses, typechecks, and
-- desugars the module, then returns the resulting Core module (consisting of
1017 1018
-- the module name, type declarations, and function declarations) if
-- successful.
1019
compileToCoreModule :: GhcMonad m => FilePath -> m CoreModule