GHC.hs 65.9 KB
Newer Older
1
{-# LANGUAGE CPP, NondecreasingIndentation, ScopedTypeVariables #-}
2
{-# LANGUAGE TupleSections, NamedFieldPuns #-}
3 4
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TypeFamilies #-}
5

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

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

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

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

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

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

        -- ** Compiling to Core
        CoreModule(..),
61
        compileToCoreModule, compileToCoreSimplified,
62

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

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

91
        -- * Querying the environment
92
        -- packageDbModules,
93

dterei's avatar
dterei committed
94 95
        -- * Printing
        PrintUnqualified, alwaysQualify,
96

dterei's avatar
dterei committed
97
        -- * Interactive evaluation
98 99

        -- ** Executing statements
100
        execStmt, execStmt', ExecOptions(..), execOptions, ExecResult(..),
101 102 103
        resumeExec,

        -- ** Adding new declarations
104
        runDecls, runDeclsWithLocation, runParsedDecls,
105 106 107 108

        -- ** Get/set the current context
        parseImportDecl,
        setContext, getContext,
109
        setGHCiMonad, getGHCiMonad,
110

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

        -- ** Inspecting types and kinds
125
        exprType, TcRnExprMode(..),
dterei's avatar
dterei committed
126
        typeKind,
127 128

        -- ** Looking up a Name
dterei's avatar
dterei committed
129
        parseName,
130
        lookupName,
131

132
        -- ** Compiling expressions
133
        HValue, parseExpr, compileParsedExpr,
134
        GHC.Runtime.Eval.compileExpr, dynCompileExpr,
135 136
        ForeignHValue,
        compileExprRemote, compileParsedExprRemote,
137

138 139 140
        -- ** Docs
        getDocs, GetDocsFailure(..),

141
        -- ** Other
142
        runTcInteractive,   -- Desired by some clients (#8878)
143
        isStmt, hasImport, isImport, isDecl,
144 145 146

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

dterei's avatar
dterei committed
159
        -- * Abstract syntax elements
160

161 162
        -- ** Units
        Unit,
Simon Marlow's avatar
Simon Marlow committed
163

dterei's avatar
dterei committed
164
        -- ** Modules
165
        Module, mkModule, pprModule, moduleName, moduleUnit,
Simon Marlow's avatar
Simon Marlow committed
166
        ModuleName, mkModuleName, moduleNameString,
167

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

dterei's avatar
dterei committed
174 175 176 177 178 179 180
        -- ** Identifiers
        Id, idType,
        isImplicitId, isDeadBinder,
        isExportedId, isLocalId, isGlobalId,
        isRecordSelector,
        isPrimOpId, isFCallId, isClassOpId_maybe,
        isDataConWorkId, idDataCon,
181
        isDeadEndId, isDictonaryId,
Adam Gundry's avatar
Adam Gundry committed
182
        recordSelectorTyCon,
dterei's avatar
dterei committed
183 184

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

        -- ** Type variables
        TyVar,
        alphaTyVars,

        -- ** Data constructors
        DataCon,
Krzysztof Gogolewski's avatar
Krzysztof Gogolewski committed
199
        dataConType, dataConTyCon, dataConFieldLabels,
Krzysztof Gogolewski's avatar
Krzysztof Gogolewski committed
200
        dataConIsInfix, isVanillaDataCon, dataConWrapperType,
Simon Peyton Jones's avatar
Simon Peyton Jones committed
201
        dataConSrcBangs,
dterei's avatar
dterei committed
202 203 204
        StrictnessMark(..), isMarkedStrict,

        -- ** Classes
205
        Class,
dterei's avatar
dterei committed
206 207 208 209
        classMethods, classSCTheta, classTvsFds, classATs,
        pprFundeps,

        -- ** Instances
210 211
        ClsInst,
        instanceDFunId,
212
        pprInstance, pprInstanceHdr,
213
        pprFamInst,
214

215
        FamInst,
216

dterei's avatar
dterei committed
217
        -- ** Types and Kinds
218 219
        Type, splitForAllTys, funResultTy,
        pprParendType, pprTypeApp,
dterei's avatar
dterei committed
220 221
        Kind,
        PredType,
Ben Gamari's avatar
Ben Gamari committed
222
        ThetaType, pprForAll, pprThetaArrowTy,
xldenis's avatar
xldenis committed
223 224
        parseInstanceHead,
        getInstancesForType,
225

dterei's avatar
dterei committed
226
        -- ** Entities
227
        TyThing(..),
228

dterei's avatar
dterei committed
229
        -- ** Syntax
Sylvain Henry's avatar
Sylvain Henry committed
230
        module GHC.Hs, -- ToDo: remove extraneous bits
231

dterei's avatar
dterei committed
232
        -- ** Fixities
233 234
        FixityDirection(..),
        defaultFixity, maxPrecedence,
dterei's avatar
dterei committed
235 236
        negateFixity,
        compareFixity,
237
        LexicalFixity(..),
238

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

250
        -- ** Located
dterei's avatar
dterei committed
251
        GenLocated(..), Located,
252

dterei's avatar
dterei committed
253 254
        -- *** Constructing Located
        noLoc, mkGeneralLocated,
255

dterei's avatar
dterei committed
256 257
        -- *** Deconstructing Located
        getLoc, unLoc,
258 259
        getRealSrcSpan, unRealSrcSpan,

dterei's avatar
dterei committed
260 261
        -- *** Combining and comparing Located values
        eqLocated, cmpLocated, combineLocs, addCLoc,
262
        leftmost_smallest, leftmost_largest, rightmost_smallest,
263 264
        spans, isSubspanOf,

dterei's avatar
dterei committed
265 266
        -- * Exceptions
        GhcException(..), showGhcException,
267

Jedai's avatar
Jedai committed
268 269 270 271 272
        -- * Token stream manipulations
        Token,
        getTokenStream, getRichTokenStream,
        showRichTokenStream, addSourceToTokens,

273 274 275
        -- * Pure interface to the parser
        parser,

Alan Zimmerman's avatar
Alan Zimmerman committed
276
        -- * API Annotations
277
        ApiAnns(..),AnnKeywordId(..),AnnotationComment(..),
Alan Zimmerman's avatar
Alan Zimmerman committed
278 279
        getAnnotation, getAndRemoveAnnotation,
        getAnnotationComments, getAndRemoveAnnotationComments,
Alan Zimmerman's avatar
Alan Zimmerman committed
280
        unicodeAnn,
Alan Zimmerman's avatar
Alan Zimmerman committed
281

dterei's avatar
dterei committed
282 283 284
        -- * Miscellaneous
        --sessionHscEnv,
        cyclicModuleErr,
285 286
  ) where

287 288 289
{-
 ToDo:

Sylvain Henry's avatar
Sylvain Henry committed
290
  * inline bits of GHC.Driver.Main here to simplify layering: hscTcExpr, hscStmt.
291 292 293 294
-}

#include "HsVersions.h"

295
import GHC.Prelude hiding (init)
296

297 298 299 300
import GHC.ByteCode.Types
import GHC.Runtime.Eval
import GHC.Runtime.Eval.Types
import GHC.Runtime.Interpreter
301
import GHC.Runtime.Interpreter.Types
302
import GHCi.RemoteTypes
303

Sylvain Henry's avatar
Sylvain Henry committed
304
import GHC.Core.Ppr.TyThing  ( pprFamInst )
Sylvain Henry's avatar
Sylvain Henry committed
305 306
import GHC.Driver.Main
import GHC.Driver.Make
307
import GHC.Driver.Hooks
Sylvain Henry's avatar
Sylvain Henry committed
308 309
import GHC.Driver.Pipeline   ( compileOne' )
import GHC.Driver.Monad
Sylvain Henry's avatar
Sylvain Henry committed
310 311 312
import GHC.Tc.Utils.Monad    ( finalSafeMode, fixSafeInstances, initIfaceTcRn )
import GHC.Iface.Load        ( loadSysInterface )
import GHC.Tc.Types
Sylvain Henry's avatar
Sylvain Henry committed
313
import GHC.Core.Predicate
Sylvain Henry's avatar
Sylvain Henry committed
314
import GHC.Unit.State
Sylvain Henry's avatar
Sylvain Henry committed
315 316
import GHC.Types.Name.Set
import GHC.Types.Name.Reader
Sylvain Henry's avatar
Sylvain Henry committed
317
import GHC.Hs
Sylvain Henry's avatar
Sylvain Henry committed
318
import GHC.Core.Type  hiding( typeKind )
Sylvain Henry's avatar
Sylvain Henry committed
319
import GHC.Tc.Utils.TcType
Sylvain Henry's avatar
Sylvain Henry committed
320
import GHC.Types.Id
Sylvain Henry's avatar
Sylvain Henry committed
321
import GHC.Builtin.Types.Prim ( alphaTyVars )
Sylvain Henry's avatar
Sylvain Henry committed
322 323 324 325 326 327 328
import GHC.Core.TyCon
import GHC.Core.TyCo.Ppr   ( pprForAll )
import GHC.Core.Class
import GHC.Core.DataCon
import GHC.Core.FVs        ( orphNamesOfFamInst )
import GHC.Core.FamInstEnv ( FamInst, famInstEnvElts )
import GHC.Core.InstEnv
Sylvain Henry's avatar
Sylvain Henry committed
329 330 331
import GHC.Types.Name      hiding ( varName )
import GHC.Types.Avail
import GHC.Types.SrcLoc
Sylvain Henry's avatar
Sylvain Henry committed
332
import GHC.Core
333
import GHC.Iface.Tidy
Sylvain Henry's avatar
Sylvain Henry committed
334
import GHC.Driver.Phases   ( Phase(..), isHaskellSrcFilename )
Sylvain Henry's avatar
Sylvain Henry committed
335 336 337 338
import GHC.Driver.Finder
import GHC.Driver.Types
import GHC.Driver.CmdLine
import GHC.Driver.Session hiding (WarnReason(..))
Sylvain Henry's avatar
Sylvain Henry committed
339
import GHC.Driver.Ways
Sylvain Henry's avatar
Sylvain Henry committed
340 341
import GHC.SysTools
import GHC.SysTools.BaseDir
Sylvain Henry's avatar
Sylvain Henry committed
342
import GHC.Types.Annotations
Sylvain Henry's avatar
Sylvain Henry committed
343
import GHC.Unit.Module
344
import GHC.Utils.Panic
John Ericson's avatar
John Ericson committed
345
import GHC.Platform
346 347 348 349 350 351
import GHC.Data.Bag        ( listToBag )
import GHC.Utils.Error
import GHC.Utils.Monad
import GHC.Utils.Misc
import GHC.Data.StringBuffer
import GHC.Utils.Outputable
Sylvain Henry's avatar
Sylvain Henry committed
352
import GHC.Types.Basic
353
import GHC.Data.FastString
Sylvain Henry's avatar
Sylvain Henry committed
354 355 356
import qualified GHC.Parser as Parser
import GHC.Parser.Lexer
import GHC.Parser.Annotation
357
import qualified GHC.LanguageExtensions as LangExt
Sylvain Henry's avatar
Sylvain Henry committed
358
import GHC.Types.Name.Env
Sylvain Henry's avatar
Sylvain Henry committed
359 360 361
import GHC.Tc.Module
import GHC.Tc.Utils.Instantiate
import GHC.Tc.Instance.Family
Sylvain Henry's avatar
Sylvain Henry committed
362
import GHC.SysTools.FileCleanup
363

364 365
import Data.Foldable
import qualified Data.Map.Strict as Map
Douglas Wilson's avatar
Douglas Wilson committed
366
import Data.Set (Set)
Sylvain Henry's avatar
Sylvain Henry committed
367
import qualified Data.Set as S
368
import qualified Data.Sequence as Seq
369
import Data.Maybe
370
import Data.Time
371 372
import Data.Typeable    ( Typeable )
import Data.Word        ( Word8 )
373
import Control.Monad
dterei's avatar
dterei committed
374
import System.Exit      ( exitWith, ExitCode(..) )
375
import GHC.Utils.Exception
376
import Data.IORef
Ian Lynagh's avatar
Ian Lynagh committed
377
import System.FilePath
378 379
import Control.Concurrent
import Control.Applicative ((<|>))
380
import Control.Monad.Catch as MC
381

382
import GHC.Data.Maybe
383 384 385 386
import System.IO.Error  ( isDoesNotExistError )
import System.Environment ( getEnv )
import System.Directory

387

388
-- %************************************************************************
dterei's avatar
dterei committed
389
-- %*                                                                      *
390
--             Initialisation: exception handlers
dterei's avatar
dterei committed
391
-- %*                                                                      *
392 393
-- %************************************************************************

394 395 396 397 398

-- | 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.
399
defaultErrorHandler :: (ExceptionMonad m)
Ian Lynagh's avatar
Ian Lynagh committed
400 401
                    => FatalMessager -> FlushOut -> m a -> m a
defaultErrorHandler fm (FlushOut flushOut) inner =
402
  -- top-level exception handler: any unrecognised exception is a compiler bug.
403
  MC.handle (\exception -> liftIO $ do
404
           flushOut
405
           case fromException exception of
406 407
                -- an IO exception probably isn't our fault, so don't panic
                Just (ioe :: IOException) ->
Ian Lynagh's avatar
Ian Lynagh committed
408
                  fatalErrorMsg'' fm (show ioe)
409
                _ -> case fromException exception of
410 411 412 413
                     Just UserInterrupt ->
                         -- Important to let this one propagate out so our
                         -- calling process knows we were interrupted by ^C
                         liftIO $ throwIO UserInterrupt
414
                     Just StackOverflow ->
Ian Lynagh's avatar
Ian Lynagh committed
415
                         fatalErrorMsg'' fm "stack overflow: use +RTS -K<size> to increase it"
416
                     _ -> case fromException exception of
417
                          Just (ex :: ExitCode) -> liftIO $ throwIO ex
418
                          _ ->
Ian Lynagh's avatar
Ian Lynagh committed
419 420
                              fatalErrorMsg'' fm
                                  (show (Panic (show exception)))
421
           exitWith (ExitFailure 1)
422 423
         ) $

424
  -- error messages propagated as exceptions
425
  handleGhcException
426
            (\ge -> liftIO $ do
427
                flushOut
dterei's avatar
dterei committed
428 429
                case ge of
                     Signal _ -> exitWith (ExitFailure 1)
Ian Lynagh's avatar
Ian Lynagh committed
430
                     _ -> do fatalErrorMsg'' fm (show ge)
dterei's avatar
dterei committed
431 432
                             exitWith (ExitFailure 1)
            ) $
433 434
  inner

435 436 437 438 439
-- | 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
440
 where _warning_suppression = m `MC.onException` undefined
441

442

443
-- %************************************************************************
dterei's avatar
dterei committed
444
-- %*                                                                      *
445
--             The Ghc Monad
dterei's avatar
dterei committed
446
-- %*                                                                      *
447
-- %************************************************************************
448 449 450 451 452 453 454 455 456 457 458 459 460 461

-- | 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
462
  ref <- newIORef (panic "empty session")
463
  let session = Session ref
Sylvain HENRY's avatar
Sylvain HENRY committed
464
  flip unGhc session $ withSignalHandlers $ do -- catch ^C
465
    initGhcMonad mb_top_dir
466 467
    withCleanupSession ghc

468 469 470 471 472 473
-- | 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.

474
runGhcT :: ExceptionMonad m =>
475 476 477 478
           Maybe FilePath  -- ^ See argument to 'initGhcMonad'.
        -> GhcT m a        -- ^ The action to perform.
        -> m a
runGhcT mb_top_dir ghct = do
479
  ref <- liftIO $ newIORef (panic "empty session")
480
  let session = Session ref
Sylvain HENRY's avatar
Sylvain HENRY committed
481
  flip unGhcT session $ withSignalHandlers $ do -- catch ^C
482
    initGhcMonad mb_top_dir
483 484 485
    withCleanupSession ghct

withCleanupSession :: GhcMonad m => m a -> m a
486
withCleanupSession ghc = ghc `MC.finally` cleanup
487 488 489 490 491 492 493
  where
   cleanup = do
      hsc_env <- getSession
      let dflags = hsc_dflags hsc_env
      liftIO $ do
          cleanTempFiles dflags
          cleanTempDirs dflags
494
          stopInterp hsc_env -- shut down the IServ
495 496 497
          --  exceptions will be blocked while we clean the temporary files,
          -- so there shouldn't be any difficulty if we receive further
          -- signals.
498 499 500 501 502 503 504 505 506 507 508

-- | 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
509
-- <http://hackage.haskell.org/package/ghc-paths>.
510 511

initGhcMonad :: GhcMonad m => Maybe FilePath -> m ()
512 513
initGhcMonad mb_top_dir
  = do { env <- liftIO $
514 515
                do { top_dir <- findTopDir mb_top_dir
                   ; mySettings <- initSysTools top_dir
516
                   ; myLlvmConfig <- lazyInitLlvmConfig top_dir
517
                   ; dflags <- initDynFlags (defaultDynFlags mySettings myLlvmConfig)
518
                   ; checkBrokenTablesNextToCode dflags
519 520 521 522 523
                   ; setUnsafeGlobalDynFlags dflags
                      -- c.f. DynFlags.parseDynamicFlagsFull, which
                      -- creates DynFlags and sets the UnsafeGlobalDynFlags
                   ; newHscEnv dflags }
       ; setSession env }
524

525 526 527 528 529
-- | 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
530
-- https://gitlab.haskell.org/ghc/ghc/issues/4210#note_78333
531 532 533 534
checkBrokenTablesNextToCode :: MonadIO m => DynFlags -> m ()
checkBrokenTablesNextToCode dflags
  = do { broken <- checkBrokenTablesNextToCode' dflags
       ; when broken
535
         $ do { _ <- liftIO $ throwIO $ mkApiErr dflags invalidLdErr
536
              ; liftIO $ fail "unsupported linker"
537 538
              }
       }
539 540 541 542
  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)"
543 544 545

checkBrokenTablesNextToCode' :: MonadIO m => DynFlags -> m Bool
checkBrokenTablesNextToCode' dflags
Sylvain Henry's avatar
Sylvain Henry committed
546 547
  | not (isARM arch)                 = return False
  | WayDyn `S.notMember` ways dflags = return False
548
  | not tablesNextToCode             = return False
Sylvain Henry's avatar
Sylvain Henry committed
549
  | otherwise                        = do
550 551 552 553 554 555
    linkerInfo <- liftIO $ getLinkerInfo dflags
    case linkerInfo of
      GnuLD _  -> return True
      _        -> return False
  where platform = targetPlatform dflags
        arch = platformArch platform
556
        tablesNextToCode = platformTablesNextToCode platform
557

558 559

-- %************************************************************************
dterei's avatar
dterei committed
560
-- %*                                                                      *
561
--             Flags & settings
dterei's avatar
dterei committed
562
-- %*                                                                      *
563
-- %************************************************************************
564

565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591
-- $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).
592 593 594 595 596 597
--
-- 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.
--
598
setSessionDynFlags :: GhcMonad m => DynFlags -> m ()
599
setSessionDynFlags dflags = do
600
  dflags' <- checkNewDynFlags dflags
601
  dflags''' <- liftIO $ initUnits dflags'
602 603 604 605 606 607 608

  -- Interpreter
  interp  <- if gopt Opt_ExternalInterpreter dflags
    then do
         let
           prog = pgm_i dflags ++ flavour
           flavour
Sylvain Henry's avatar
Sylvain Henry committed
609 610 611
             | WayProf `S.member` ways dflags = "-prof"
             | WayDyn `S.member` ways dflags  = "-dyn"
             | otherwise                      = ""
612 613
           msg = text "Starting " <> text prog
         tr <- if verbosity dflags >= 3
614
                then return (logInfo dflags $ withPprStyle defaultDumpStyle msg)
615 616 617
                else return (pure ())
         let
          conf = IServConfig
618 619 620
            { iservConfProgram  = prog
            , iservConfOpts     = getOpts dflags opt_i
            , iservConfProfiled = gopt Opt_SccProfilingOn dflags
Sylvain Henry's avatar
Sylvain Henry committed
621
            , iservConfDynamic  = WayDyn `S.member` ways dflags
622 623
            , iservConfHook     = createIservProcessHook (hooks dflags)
            , iservConfTrace    = tr
624
            }
625 626
         s <- liftIO $ newMVar IServPending
         return (Just (ExternalInterp conf (IServ s)))
627 628 629 630 631 632 633
    else
#if defined(HAVE_INTERNAL_INTERPRETER)
      return (Just InternalInterp)
#else
      return Nothing
#endif

634
  modifySession $ \h -> h{ hsc_dflags = dflags'''
635 636 637 638 639
                         , hsc_IC = (hsc_IC h){ ic_dflags = dflags''' }
                         , hsc_interp = hsc_interp h <|> interp
                           -- we only update the interpreter if there wasn't
                           -- already one set up
                         }
640
  invalidateModSummaryCache
641

642 643 644
-- | Sets the program 'DynFlags'.  Note: this invalidates the internal
-- cached module graph, causing more work to be done the next time
-- 'load' is called.
645 646 647 648
--
-- Returns a boolean indicating if preload units have changed and need to be
-- reloaded.
setProgramDynFlags :: GhcMonad m => DynFlags -> m Bool
649 650 651 652 653
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.
654 655
setLogAction :: GhcMonad m => LogAction -> m ()
setLogAction action = do
656 657
  dflags' <- getProgramDynFlags
  void $ setProgramDynFlags_ False $
658
    dflags' { log_action = action }
659

660
setProgramDynFlags_ :: GhcMonad m => Bool -> DynFlags -> m Bool
661
setProgramDynFlags_ invalidate_needed dflags = do
662
  dflags' <- checkNewDynFlags dflags
663
  dflags_prev <- getProgramDynFlags
664 665 666 667
  let changed = packageFlagsChanged dflags_prev dflags'
  dflags'' <- if changed
               then liftIO $ initUnits dflags'
               else return dflags'
668
  modifySession $ \h -> h{ hsc_dflags = dflags'' }
669
  when invalidate_needed $ invalidateModSummaryCache
670
  return changed
671

672

673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688
-- 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
689
-- recompile a module, we'll have re-summarised the module and have a
690 691 692 693
-- correct ModSummary.
--
invalidateModSummaryCache :: GhcMonad m => m ()
invalidateModSummaryCache =
694
  modifySession $ \h -> h { hsc_mod_graph = mapMG inval (hsc_mod_graph h) }
695 696 697
 where
  inval ms = ms { ms_hs_date = addUTCTime (-1) (ms_hs_date ms) }

698 699 700 701 702 703 704
-- | 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
Sylvain Henry's avatar
Sylvain Henry committed
705
-- 'unitState' into the interactive @DynFlags@.
706 707
setInteractiveDynFlags :: GhcMonad m => DynFlags -> m ()
setInteractiveDynFlags dflags = do
708
  dflags' <- checkNewDynFlags dflags
709 710
  dflags'' <- checkNewInteractiveDynFlags dflags'
  modifySession $ \h -> h{ hsc_IC = (hsc_IC h) { ic_dflags = dflags'' }}
711 712 713 714 715

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

716

717
parseDynamicFlags :: MonadIO m =>
718
                     DynFlags -> [Located String]
719
                  -> m (DynFlags, [Located String], [Warn])
720 721 722 723 724
parseDynamicFlags dflags cmdline = do
  (dflags1, leftovers, warns) <- parseDynamicFlagsCmdLine dflags cmdline
  dflags2 <- liftIO $ interpretPackageEnv dflags1
  return (dflags2, leftovers, warns)

725

726 727 728 729
-- | 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
730 731 732
checkNewDynFlags dflags = do
  -- See Note [DynFlags consistency]
  let (dflags', warnings) = makeDynFlagsConsistent dflags
733
  liftIO $ handleFlagWarnings dflags (map (Warn NoReason) warnings)
Ben Gamari's avatar
Ben Gamari committed
734
  return dflags'
735

736 737
checkNewInteractiveDynFlags :: MonadIO m => DynFlags -> m DynFlags
checkNewInteractiveDynFlags dflags0 = do
738 739
  -- We currently don't support use of StaticPointers in expressions entered on
  -- the REPL. See #12356.
Krzysztof Gogolewski's avatar
Krzysztof Gogolewski committed
740 741 742 743 744 745
  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
746 747


748
-- %************************************************************************
dterei's avatar
dterei committed
749
-- %*                                                                      *
750
--             Setting, getting, and modifying the targets
dterei's avatar
dterei committed
751
-- %*                                                                      *
752
-- %************************************************************************
753 754 755 756 757 758

-- 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
759
-- the program\/library.  Unloading the current program is achieved by
760 761 762
-- 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 })
763

764 765 766
-- | Returns the current set of targets
getTargets :: GhcMonad m => m [Target]
getTargets = withSession (return . hsc_targets)
767

768 769 770 771
-- | Add another target.
addTarget :: GhcMonad m => Target -> m ()
addTarget target
  = modifySession (\h -> h{ hsc_targets = target : hsc_targets h })
772

773
-- | Remove a target
774 775 776
removeTarget :: GhcMonad m => TargetId -> m ()
removeTarget target_id
  = modifySession (\h -> h{ hsc_targets = filter (hsc_targets h) })
777
  where
Simon Marlow's avatar
Simon Marlow committed
778
   filter targets = [ t | t@(Target id _ _) <- targets, id /= target_id ]
779

780 781 782 783 784 785 786 787
-- | 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
788
--
789
--   - otherwise interpret the string as a module name
790
--
791
guessTarget :: GhcMonad m => String -> Maybe Phase -> m Target
Simon Marlow's avatar
Simon Marlow committed
792 793 794
guessTarget str (Just phase)
   = return (Target (TargetFile str (Just phase)) True Nothing)
guessTarget str Nothing
795
   | isHaskellSrcFilename file