GHC.hs 58.1 KB
Newer Older
1
{-# LANGUAGE CPP, NondecreasingIndentation, ScopedTypeVariables #-}
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,
Adam Gundry's avatar
Adam Gundry committed
76
        modInfoExportsWithSelectors,
dterei's avatar
dterei committed
77 78 79
        modInfoInstances,
        modInfoIsExportedName,
        modInfoLookupName,
80
        modInfoIface,
81
        modInfoSafe,
dterei's avatar
--amend  
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,
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

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

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

dterei's avatar
dterei committed
153
        -- * Abstract syntax elements
154

Simon Marlow's avatar
Simon Marlow committed
155
        -- ** Packages
156
        UnitId,
Simon Marlow's avatar
Simon Marlow committed
157

dterei's avatar
dterei committed
158
        -- ** Modules
159
        Module, mkModule, pprModule, moduleName, moduleUnitId,
Simon Marlow's avatar
Simon Marlow committed
160
        ModuleName, mkModuleName, moduleNameString,
161

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

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

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

        -- ** Type variables
        TyVar,
        alphaTyVars,

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

        -- ** Classes
199
        Class,
dterei's avatar
dterei committed
200 201 202 203
        classMethods, classSCTheta, classTvsFds, classATs,
        pprFundeps,

        -- ** Instances
204 205
        ClsInst,
        instanceDFunId,
206
        pprInstance, pprInstanceHdr,
207
        pprFamInst,
208

209
        FamInst,
210

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

dterei's avatar
dterei committed
218
        -- ** Entities
219
        TyThing(..),
220

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

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

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

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

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

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

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

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

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

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

Alan Zimmerman's avatar
Alan Zimmerman committed
267 268
        -- * API Annotations
        ApiAnns,AnnKeywordId(..),AnnotationComment(..),
Alan Zimmerman's avatar
Alan Zimmerman committed
269 270
        getAnnotation, getAndRemoveAnnotation,
        getAnnotationComments, getAndRemoveAnnotationComments,
Alan Zimmerman's avatar
Alan Zimmerman committed
271
        unicodeAnn,
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
-}

#include "HsVersions.h"

286
import ByteCodeTypes
287
import InteractiveEval
288
import InteractiveEvalTypes
289
import TcRnDriver       ( runTcInteractive )
290 291
import GHCi
import GHCi.RemoteTypes
292

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

349 350
import Data.Foldable
import qualified Data.Map.Strict as Map
Douglas Wilson's avatar
Douglas Wilson committed
351
import Data.Set (Set)
352
import qualified Data.Sequence as Seq
Austin Seipp's avatar
Austin Seipp committed
353
import System.Directory ( doesFileExist )
354
import Data.Maybe
dterei's avatar
dterei committed
355
import Data.List        ( find )
356
import Data.Time
357 358
import Data.Typeable    ( Typeable )
import Data.Word        ( Word8 )
359
import Control.Monad
dterei's avatar
dterei committed
360
import System.Exit      ( exitWith, ExitCode(..) )
361
import Exception
362
import Data.IORef
Ian Lynagh's avatar
Ian Lynagh committed
363
import System.FilePath
364
import System.IO
Ian Lynagh's avatar
Ian Lynagh committed
365
import Prelude hiding (init)
366

367

368
-- %************************************************************************
dterei's avatar
dterei committed
369
-- %*                                                                      *
370
--             Initialisation: exception handlers
dterei's avatar
dterei committed
371
-- %*                                                                      *
372 373
-- %************************************************************************

374 375 376 377 378

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

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

415 416 417 418 419 420
-- | 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
421

422

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

-- | 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
442
  ref <- newIORef (panic "empty session")
443
  let session = Session ref
Sylvain HENRY's avatar
Sylvain HENRY committed
444
  flip unGhc session $ withSignalHandlers $ do -- catch ^C
445
    initGhcMonad mb_top_dir
446 447
    withCleanupSession ghc

448 449 450 451 452 453
-- | 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.

454
runGhcT :: ExceptionMonad m =>
455 456 457 458
           Maybe FilePath  -- ^ See argument to 'initGhcMonad'.
        -> GhcT m a        -- ^ The action to perform.
        -> m a
runGhcT mb_top_dir ghct = do
459
  ref <- liftIO $ newIORef (panic "empty session")
460
  let session = Session ref
Sylvain HENRY's avatar
Sylvain HENRY committed
461
  flip unGhcT session $ withSignalHandlers $ do -- catch ^C
462
    initGhcMonad mb_top_dir
463 464 465 466 467 468 469 470 471 472 473 474
    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
475
          log_finaliser dflags dflags
476 477 478
          --  exceptions will be blocked while we clean the temporary files,
          -- so there shouldn't be any difficulty if we receive further
          -- signals.
479 480 481 482 483 484 485 486 487 488 489

-- | 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
490
-- <http://hackage.haskell.org/package/ghc-paths>.
491 492

initGhcMonad :: GhcMonad m => Maybe FilePath -> m ()
493 494
initGhcMonad mb_top_dir
  = do { env <- liftIO $
Sylvain Henry's avatar
Sylvain Henry committed
495
                do { mySettings <- initSysTools mb_top_dir
496
                   ; dflags <- initDynFlags (defaultDynFlags mySettings)
497
                   ; checkBrokenTablesNextToCode dflags
498 499 500 501 502
                   ; setUnsafeGlobalDynFlags dflags
                      -- c.f. DynFlags.parseDynamicFlagsFull, which
                      -- creates DynFlags and sets the UnsafeGlobalDynFlags
                   ; newHscEnv dflags }
       ; setSession env }
503

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

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

536 537

-- %************************************************************************
dterei's avatar
dterei committed
538
-- %*                                                                      *
539
--             Flags & settings
dterei's avatar
dterei committed
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 566 567 568 569
-- $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).
570 571 572 573 574 575
--
-- 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.
--
576
setSessionDynFlags :: GhcMonad m => DynFlags -> m [InstalledUnitId]
577
setSessionDynFlags dflags = do
578 579 580 581
  dflags' <- checkNewDynFlags dflags
  (dflags'', preload) <- liftIO $ initPackages dflags'
  modifySession $ \h -> h{ hsc_dflags = dflags''
                         , hsc_IC = (hsc_IC h){ ic_dflags = dflags'' } }
582
  invalidateModSummaryCache
583 584
  return preload

585 586 587
-- | Sets the program 'DynFlags'.  Note: this invalidates the internal
-- cached module graph, causing more work to be done the next time
-- 'load' is called.
588
setProgramDynFlags :: GhcMonad m => DynFlags -> m [InstalledUnitId]
589 590 591 592 593 594 595 596 597 598 599 600 601 602
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.
setLogAction :: GhcMonad m => LogAction -> LogFinaliser -> m ()
setLogAction action finaliser = do
  dflags' <- getProgramDynFlags
  void $ setProgramDynFlags_ False $
    dflags' { log_action = action
            , log_finaliser = finaliser }

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

613

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

639 640 641 642 643 644 645 646 647 648
-- | 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
649
  dflags' <- checkNewDynFlags dflags
650 651
  dflags'' <- checkNewInteractiveDynFlags dflags'
  modifySession $ \h -> h{ hsc_IC = (hsc_IC h) { ic_dflags = dflags'' }}
652 653 654 655 656

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

657

658
parseDynamicFlags :: MonadIO m =>
659
                     DynFlags -> [Located String]
660
                  -> m (DynFlags, [Located String], [Warn])
661 662
parseDynamicFlags = parseDynamicFlagsCmdLine

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

673 674 675 676 677 678 679 680 681 682 683 684
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


685
-- %************************************************************************
dterei's avatar
dterei committed
686
-- %*                                                                      *
687
--             Setting, getting, and modifying the targets
dterei's avatar
dterei committed
688
-- %*                                                                      *
689
-- %************************************************************************
690 691 692 693 694 695

-- 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
696
-- the program\/library.  Unloading the current program is achieved by
697 698 699
-- 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 })
700

701 702 703
-- | Returns the current set of targets
getTargets :: GhcMonad m => m [Target]
getTargets = withSession (return . hsc_targets)
704

705 706 707 708
-- | Add another target.
addTarget :: GhcMonad m => Target -> m ()
addTarget target
  = modifySession (\h -> h{ hsc_targets = target : hsc_targets h })
709

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

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

dterei's avatar
dterei committed
756 757
         hs_file  = file <.> "hs"
         lhs_file = file <.> "lhs"
758

Simon Marlow's avatar
Simon Marlow committed
759 760
         target tid = Target tid obj_allowed Nothing

761

762 763
-- | Inform GHC that the working directory has changed.  GHC will flush
-- its cache of module locations, since it may no longer be valid.
764
--
765 766 767 768 769 770
-- 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)
771

772 773

-- %************************************************************************
dterei's avatar
dterei committed
774
-- %*                                                                      *
775
--             Running phases one at a time
dterei's avatar
dterei committed
776
-- %*                                                                      *
777
-- %************************************************************************
778 779 780 781 782 783 784 785 786 787

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
788 789 790 791 792
        -- 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.
793 794 795 796 797 798 799

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

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

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