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

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

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

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

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

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

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

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

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

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

85
        -- * Querying the environment
86
        -- packageDbModules,
87

dterei's avatar
dterei committed
88
89
        -- * Printing
        PrintUnqualified, alwaysQualify,
90

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

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

        -- ** Adding new declarations
        runDecls, runDeclsWithLocation,

        -- ** Get/set the current context
        parseImportDecl,
        setContext, getContext,
103
        setGHCiMonad, getGHCiMonad,
104

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

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

        -- ** Looking up a Name
dterei's avatar
dterei committed
122
        parseName,
123
        lookupName,
124

125
        -- ** Compiling expressions
126
127
        HValue, parseExpr, compileParsedExpr,
        InteractiveEval.compileExpr, dynCompileExpr,
128
129
        ForeignHValue,
        compileExprRemote, compileParsedExprRemote,
130
131

        -- ** Other
132
        runTcInteractive,   -- Desired by some clients (Trac #8878)
133
        isStmt, hasImport, isImport, isDecl,
134
135
136

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

dterei's avatar
dterei committed
149
        -- * Abstract syntax elements
150

Simon Marlow's avatar
Simon Marlow committed
151
        -- ** Packages
152
        UnitId,
Simon Marlow's avatar
Simon Marlow committed
153

dterei's avatar
dterei committed
154
        -- ** Modules
155
        Module, mkModule, pprModule, moduleName, moduleUnitId,
Simon Marlow's avatar
Simon Marlow committed
156
        ModuleName, mkModuleName, moduleNameString,
157

dterei's avatar
dterei committed
158
        -- ** Names
159
        Name,
dterei's avatar
dterei committed
160
161
162
        isExternalName, nameModule, pprParenSymName, nameSrcSpan,
        NamedThing(..),
        RdrName(Qual,Unqual),
163

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

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

        -- ** Type variables
        TyVar,
        alphaTyVars,

        -- ** Data constructors
        DataCon,
        dataConSig, dataConType, dataConTyCon, dataConFieldLabels,
        dataConIsInfix, isVanillaDataCon, dataConUserType,
Simon Peyton Jones's avatar
Simon Peyton Jones committed
191
        dataConSrcBangs,
dterei's avatar
dterei committed
192
193
194
        StrictnessMark(..), isMarkedStrict,

        -- ** Classes
195
        Class,
dterei's avatar
dterei committed
196
197
198
199
        classMethods, classSCTheta, classTvsFds, classATs,
        pprFundeps,

        -- ** Instances
200
201
        ClsInst,
        instanceDFunId,
202
        pprInstance, pprInstanceHdr,
203
        pprFamInst,
204

205
        FamInst,
206

dterei's avatar
dterei committed
207
        -- ** Types and Kinds
208
209
        Type, splitForAllTys, funResultTy,
        pprParendType, pprTypeApp,
dterei's avatar
dterei committed
210
211
        Kind,
        PredType,
Ben Gamari's avatar
Ben Gamari committed
212
        ThetaType, pprForAll, pprThetaArrowTy,
213

dterei's avatar
dterei committed
214
        -- ** Entities
215
        TyThing(..),
216

dterei's avatar
dterei committed
217
218
        -- ** Syntax
        module HsSyn, -- ToDo: remove extraneous bits
219

dterei's avatar
dterei committed
220
        -- ** Fixities
221
222
        FixityDirection(..),
        defaultFixity, maxPrecedence,
dterei's avatar
dterei committed
223
224
        negateFixity,
        compareFixity,
225
        LexicalFixity(..),
226

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

238
        -- ** Located
dterei's avatar
dterei committed
239
        GenLocated(..), Located,
240

dterei's avatar
dterei committed
241
242
        -- *** Constructing Located
        noLoc, mkGeneralLocated,
243

dterei's avatar
dterei committed
244
245
        -- *** Deconstructing Located
        getLoc, unLoc,
246

dterei's avatar
dterei committed
247
248
        -- *** Combining and comparing Located values
        eqLocated, cmpLocated, combineLocs, addCLoc,
249
250
251
        leftmost_smallest, leftmost_largest, rightmost,
        spans, isSubspanOf,

dterei's avatar
dterei committed
252
253
        -- * Exceptions
        GhcException(..), showGhcException,
254

Jedai's avatar
Jedai committed
255
256
257
258
259
        -- * Token stream manipulations
        Token,
        getTokenStream, getRichTokenStream,
        showRichTokenStream, addSourceToTokens,

260
261
262
        -- * Pure interface to the parser
        parser,

Alan Zimmerman's avatar
Alan Zimmerman committed
263
264
        -- * API Annotations
        ApiAnns,AnnKeywordId(..),AnnotationComment(..),
Alan Zimmerman's avatar
Alan Zimmerman committed
265
266
        getAnnotation, getAndRemoveAnnotation,
        getAnnotationComments, getAndRemoveAnnotationComments,
Alan Zimmerman's avatar
Alan Zimmerman committed
267
        unicodeAnn,
Alan Zimmerman's avatar
Alan Zimmerman committed
268

dterei's avatar
dterei committed
269
270
271
        -- * Miscellaneous
        --sessionHscEnv,
        cyclicModuleErr,
272
273
  ) where

274
275
276
{-
 ToDo:

277
  * inline bits of HscMain here to simplify layering: hscTcExpr, hscStmt.
278
279
280
281
-}

#include "HsVersions.h"

282
import ByteCodeTypes
283
import InteractiveEval
284
import InteractiveEvalTypes
285
import TcRnDriver       ( runTcInteractive )
286
287
import GHCi
import GHCi.RemoteTypes
288

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

Austin Seipp's avatar
Austin Seipp committed
338
import System.Directory ( doesFileExist )
339
import Data.Maybe
dterei's avatar
dterei committed
340
import Data.List        ( find )
341
import Data.Time
342
343
import Data.Typeable    ( Typeable )
import Data.Word        ( Word8 )
344
import Control.Monad
dterei's avatar
dterei committed
345
import System.Exit      ( exitWith, ExitCode(..) )
346
import Exception
347
import Data.IORef
Ian Lynagh's avatar
Ian Lynagh committed
348
import System.FilePath
349
import System.IO
Ian Lynagh's avatar
Ian Lynagh committed
350
import Prelude hiding (init)
351

352

353
-- %************************************************************************
dterei's avatar
dterei committed
354
-- %*                                                                      *
355
--             Initialisation: exception handlers
dterei's avatar
dterei committed
356
-- %*                                                                      *
357
358
-- %************************************************************************

359
360
361
362
363

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

389
  -- error messages propagated as exceptions
390
  handleGhcException
391
            (\ge -> liftIO $ do
392
                flushOut
dterei's avatar
dterei committed
393
394
                case ge of
                     Signal _ -> exitWith (ExitFailure 1)
Ian Lynagh's avatar
Ian Lynagh committed
395
                     _ -> do fatalErrorMsg'' fm (show ge)
dterei's avatar
dterei committed
396
397
                             exitWith (ExitFailure 1)
            ) $
398
399
  inner

400
401
402
403
404
405
-- | 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
406

407

408
-- %************************************************************************
dterei's avatar
dterei committed
409
-- %*                                                                      *
410
--             The Ghc Monad
dterei's avatar
dterei committed
411
-- %*                                                                      *
412
-- %************************************************************************
413
414
415
416
417
418
419
420
421
422
423
424
425
426

-- | 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
427
  ref <- newIORef (panic "empty session")
428
  let session = Session ref
Sylvain HENRY's avatar
Sylvain HENRY committed
429
  flip unGhc session $ withSignalHandlers $ do -- catch ^C
430
    initGhcMonad mb_top_dir
431
432
    withCleanupSession ghc

433
434
435
436
437
438
-- | 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.

439
runGhcT :: ExceptionMonad m =>
440
441
442
443
           Maybe FilePath  -- ^ See argument to 'initGhcMonad'.
        -> GhcT m a        -- ^ The action to perform.
        -> m a
runGhcT mb_top_dir ghct = do
444
  ref <- liftIO $ newIORef (panic "empty session")
445
  let session = Session ref
Sylvain HENRY's avatar
Sylvain HENRY committed
446
  flip unGhcT session $ withSignalHandlers $ do -- catch ^C
447
    initGhcMonad mb_top_dir
448
449
450
451
452
453
454
455
456
457
458
459
    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
460
          log_finaliser dflags dflags
461
462
463
          --  exceptions will be blocked while we clean the temporary files,
          -- so there shouldn't be any difficulty if we receive further
          -- signals.
464
465
466
467
468
469
470
471
472
473
474

-- | 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
475
-- <http://hackage.haskell.org/package/ghc-paths>.
476
477

initGhcMonad :: GhcMonad m => Maybe FilePath -> m ()
478
479
initGhcMonad mb_top_dir
  = do { env <- liftIO $
Sylvain Henry's avatar
Sylvain Henry committed
480
                do { mySettings <- initSysTools mb_top_dir
481
                   ; dflags <- initDynFlags (defaultDynFlags mySettings)
482
                   ; checkBrokenTablesNextToCode dflags
483
484
485
486
487
                   ; setUnsafeGlobalDynFlags dflags
                      -- c.f. DynFlags.parseDynamicFlagsFull, which
                      -- creates DynFlags and sets the UnsafeGlobalDynFlags
                   ; newHscEnv dflags }
       ; setSession env }
488

489
490
491
492
493
494
495
496
497
498
-- | 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
499
         $ do { _ <- liftIO $ throwIO $ mkApiErr dflags invalidLdErr
500
501
502
              ; fail "unsupported linker"
              }
       }
503
504
505
506
  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)"
507
508
509
510
511
512
513
514
515
516
517
518
519
520

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

521
522

-- %************************************************************************
dterei's avatar
dterei committed
523
-- %*                                                                      *
524
--             Flags & settings
dterei's avatar
dterei committed
525
-- %*                                                                      *
526
-- %************************************************************************
527

528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
-- $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).
555
556
557
558
559
560
--
-- 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.
--
561
setSessionDynFlags :: GhcMonad m => DynFlags -> m [InstalledUnitId]
562
setSessionDynFlags dflags = do
563
564
565
566
  dflags' <- checkNewDynFlags dflags
  (dflags'', preload) <- liftIO $ initPackages dflags'
  modifySession $ \h -> h{ hsc_dflags = dflags''
                         , hsc_IC = (hsc_IC h){ ic_dflags = dflags'' } }
567
  invalidateModSummaryCache
568
569
  return preload

570
571
572
-- | Sets the program 'DynFlags'.  Note: this invalidates the internal
-- cached module graph, causing more work to be done the next time
-- 'load' is called.
573
setProgramDynFlags :: GhcMonad m => DynFlags -> m [InstalledUnitId]
574
575
576
577
578
579
580
581
582
583
584
585
586
587
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
588
  dflags' <- checkNewDynFlags dflags
589
590
591
592
593
  dflags_prev <- getProgramDynFlags
  (dflags'', preload) <-
    if (packageFlagsChanged dflags_prev dflags')
       then liftIO $ initPackages dflags'
       else return (dflags', [])
594
  modifySession $ \h -> h{ hsc_dflags = dflags'' }
595
  when invalidate_needed $ invalidateModSummaryCache
596
  return preload
597

598

599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
-- When changing the DynFlags, we want the changes to apply to future
-- loads, but without completely discarding the program.  But the
-- DynFlags are cached in each ModSummary in the hsc_mod_graph, so
-- after a change to DynFlags, the changes would apply to new modules
-- but not existing modules; this seems undesirable.
--
-- Furthermore, the GHC API client might expect that changing
-- log_action would affect future compilation messages, but for those
-- modules we have cached ModSummaries for, we'll continue to use the
-- old log_action.  This is definitely wrong (#7478).
--
-- Hence, we invalidate the ModSummary cache after changing the
-- DynFlags.  We do this by tweaking the date on each ModSummary, so
-- that the next downsweep will think that all the files have changed
-- and preprocess them again.  This won't necessarily cause everything
-- to be recompiled, because by the time we check whether we need to
-- recopmile a module, we'll have re-summarised the module and have a
-- correct ModSummary.
--
invalidateModSummaryCache :: GhcMonad m => m ()
invalidateModSummaryCache =
  modifySession $ \h -> h { hsc_mod_graph = map inval (hsc_mod_graph h) }
 where
  inval ms = ms { ms_hs_date = addUTCTime (-1) (ms_hs_date ms) }

624
625
626
627
628
629
630
631
632
633
-- | 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
634
  dflags' <- checkNewDynFlags dflags
635
636
  dflags'' <- checkNewInteractiveDynFlags dflags'
  modifySession $ \h -> h{ hsc_IC = (hsc_IC h) { ic_dflags = dflags'' }}
637
638
639
640
641

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

642

643
parseDynamicFlags :: MonadIO m =>
644
645
646
647
                     DynFlags -> [Located String]
                  -> m (DynFlags, [Located String], [Located String])
parseDynamicFlags = parseDynamicFlagsCmdLine

648
649
650
651
-- | 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
652
653
654
655
656
checkNewDynFlags dflags = do
  -- See Note [DynFlags consistency]
  let (dflags', warnings) = makeDynFlagsConsistent dflags
  liftIO $ handleFlagWarnings dflags warnings
  return dflags'
657

658
659
660
661
662
663
664
665
666
667
668
669
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


670
-- %************************************************************************
dterei's avatar
dterei committed
671
-- %*                                                                      *
672
--             Setting, getting, and modifying the targets
dterei's avatar
dterei committed
673
-- %*                                                                      *
674
-- %************************************************************************
675
676
677
678
679
680

-- 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
681
-- the program\/library.  Unloading the current program is achieved by
682
683
684
-- 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 })
685

686
687
688
-- | Returns the current set of targets
getTargets :: GhcMonad m => m [Target]
getTargets = withSession (return . hsc_targets)
689

690
691
692
693
-- | Add another target.
addTarget :: GhcMonad m => Target -> m ()
addTarget target
  = modifySession (\h -> h{ hsc_targets = target : hsc_targets h })
694

695
-- | Remove a target
696
697
698
removeTarget :: GhcMonad m => TargetId -> m ()
removeTarget target_id
  = modifySession (\h -> h{ hsc_targets = filter (hsc_targets h) })
699
  where
Simon Marlow's avatar
Simon Marlow committed
700
   filter targets = [ t | t@(Target id _ _) <- targets, id /= target_id ]
701

702
703
704
705
706
707
708
709
-- | 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
710
--
711
--   - otherwise interpret the string as a module name
712
--
713
guessTarget :: GhcMonad m => String -> Maybe Phase -> m Target
Simon Marlow's avatar
Simon Marlow committed
714
715
716
guessTarget str (Just phase)
   = return (Target (TargetFile str (Just phase)) True Nothing)
guessTarget str Nothing
717
   | isHaskellSrcFilename file
Simon Marlow's avatar
Simon Marlow committed
718
   = return (target (TargetFile file Nothing))
719
   | otherwise
720
   = do exists <- liftIO $ doesFileExist hs_file
dterei's avatar
dterei committed
721
722
723
724
725
726
727
        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
728
729
730
        if looksLikeModuleName file
           then return (target (TargetModule (mkModuleName file)))
           else do
Ian Lynagh's avatar
Ian Lynagh committed
731
        dflags <- getDynFlags
732
        liftIO $ throwGhcExceptionIO
Ian Lynagh's avatar
Ian Lynagh committed
733
                 (ProgramError (showSDoc dflags $
734
                 text "target" <+> quotes (text file) <+>
Simon Marlow's avatar
Simon Marlow committed
735
                 text "is not a module name or a source file"))
736
     where
Simon Marlow's avatar
Simon Marlow committed
737
738
739
740
         (file,obj_allowed)
                | '*':rest <- str = (rest, False)
                | otherwise       = (str,  True)

dterei's avatar
dterei committed
741
742
         hs_file  = file <.> "hs"
         lhs_file = file <.> "lhs"
743

Simon Marlow's avatar
Simon Marlow committed
744
745
         target tid = Target tid obj_allowed Nothing

746

747
748
-- | Inform GHC that the working directory has changed.  GHC will flush
-- its cache of module locations, since it may no longer be valid.
749
--
750
751
752
753
754
755
-- 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)
756

757
758

-- %************************************************************************
dterei's avatar
dterei committed
759
-- %*                                                                      *
760
--             Running phases one at a time
dterei's avatar
dterei committed
761
-- %*                                                                      *
762
-- %************************************************************************
763
764
765
766
767
768
769
770
771
772

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
773
774
775
776
777
        -- 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.
778
779
780
781
782
783
784

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

-- | The result of successful parsing.
data ParsedModule =
  ParsedModule { pm_mod_summary   :: ModSummary
785
               , pm_parsed_source :: ParsedSource
Alan Zimmerman's avatar
Alan Zimmerman committed
786
787
788
               , pm_extra_src_files :: [FilePath]
               , pm_annotations :: ApiAnns }
               -- See Note [Api annotations] in ApiAnnotation.hs
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810

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
811
  moduleInfo m        = tm_checked_module_info m
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
  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
833

834
type ParsedSource      = Located (HsModule RdrName)
835
type RenamedSource     = (HsGroup Name, [LImportDecl Name], Maybe [LIE Name],
836
                          Maybe LHsDocString)
837
838
type TypecheckedSource = LHsBinds Id

839
840
841
842
843
844
845
846
847
848
849
850
-- 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

851
852
853
-- | Return the 'ModSummary' of a module with the given name.
--
-- The module must be part of the module graph (see 'hsc_mod_graph' and
854
-- 'ModuleGraph').  If this is not the case, this function will throw a
855
856
-- 'GhcApiError'.
--
857
858
-- This function ignores boot modules and requires that there is only one
-- non-boot module with the given name.
859
860
861
getModSummary :: GhcMonad m => ModuleName -> m ModSummary
getModSummary mod = do
   mg <- liftM hsc_mod_graph getSession
862
   case [ ms | ms <- mg, ms_mod_name ms == mod, not (isBootSummary ms) ] of
863
     [] -> do dflags <- getDynFlags
864
              liftIO $ throwIO $ mkApiErr dflags (text "Module not part of module graph")
865
     [ms] -> return ms
866
     multiple -> do dflags <- getDynFlags
867
                    liftIO $ throwIO $ mkApiErr dflags (text "getModSummary is ambiguous: " <+> ppr multiple)
868
869
870
871

-- | Parse a module.
--
-- Throws a 'SourceError' on parse error.
872
873
parseModule :: GhcMonad m => ModSummary -> m ParsedModule
parseModule ms = do
874
875
   hsc_env <- getSession
   let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }
876
   hpm <- liftIO $ hscParse hsc_env_tmp ms
Alan Zimmerman's avatar
Alan Zimmerman committed
877
878
879
   return (ParsedModule ms (hpm_module hpm) (hpm_src_files hpm)
                           (hpm_annotations hpm))
               -- See Note [Api annotations] in ApiAnnotation.hs
880
881
882
883
884
885

-- | Typecheck and rename a parsed module.
--
-- Throws a 'SourceError' if either fails.
typecheckModule :: GhcMonad m => ParsedModule -> m TypecheckedModule
typecheckModule pmod = do
Thomas Schilling's avatar
Thomas Schilling committed
886
 let ms = modSummary pmod
887
888
889
 hsc_env <- getSession
 let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }
 (tc_gbl_env, rn_info)
890
891
       <- liftIO $ hscTypecheckRename hsc_env_tmp ms $
                      HsParsedModule { hpm_module = parsedSource pmod,
Alan Zimmerman's avatar
Alan Zimmerman committed
892
893
                                       hpm_src_files = pm_extra_src_files pmod,
                                       hpm_annotations = pm_annotations pmod }
894
 details <- liftIO $ makeSimpleDetails hsc_env_tmp tc_gbl_env
895
 safe    <- liftIO $ finalSafeMode (ms_hspp_opts ms) tc_gbl_env
896

897
 return $
898
899
900
901
902
903
904
905
     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,
Adam Gundry's avatar
Adam Gundry committed
906
           minf_exports   = md_exports details,
907
           minf_rdr_env   = Just (tcg_rdr_env tc_gbl_env),
908
           minf_instances = fixSafeInstances safe $ md_insts details,
909
           minf_iface     = Nothing,
910
911
           minf_safe      = safe,
           minf_modBreaks = emptyModBreaks
912
913
914
915
916
         }}

-- | Desugar a typechecked module.
desugarModule :: GhcMonad m => TypecheckedModule -> m DesugaredModule
desugarModule tcm = do
Thomas Schilling's avatar
Thomas Schilling committed
917
 let ms = modSummary tcm
918
919
920
921
922
 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 $
923
924
925
926
927
928
929
     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
930
931
932
933
934
935
936
-- 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).
--
937
938
939
940
loadModule :: (TypecheckedMod mod, GhcMonad m) => mod -> m mod
loadModule tcm = do
   let ms = modSummary tcm
   let mod = ms_mod_name ms
941
   let loc = ms_location ms
942
943
   let (tcg, _details) = tm_internals tcm

944
   mb_linkable <- case ms_obj_date ms of
945
                     Just t | t > ms_hs_date ms  -> do
946
                         l <- liftIO $ findObjectLinkable (ms_mod ms)
947
948
949
                                                  (ml_obj_file loc) t
                         return (Just l)
                     _otherwise -> return Nothing
950

951
952
953
954
   let source_modified | isNothing mb_linkable = SourceModified
                       | otherwise             = SourceUnmodified
                       -- we can't determine stability here

955
956
   -- compile doesn't change the session
   hsc_env <- getSession
957
958
959
   mod_info <- liftIO $ compileOne' (Just tcg) Nothing
                                    hsc_env ms 1 1 Nothing mb_linkable
                                    source_modified
960

niteria's avatar
niteria committed
961
   modifySession $ \e -> e{ hsc_HPT = addToHpt (hsc_HPT e) mod mod_info }
962
   return tcm
963

964
965

-- %************************************************************************
dterei's avatar
dterei committed
966
-- %*                                                                      *
967
--             Dealing with Core
dterei's avatar
dterei committed
968
-- %*                                                                      *
969
-- %************************************************************************
970
971
972
973
974
975
976
977
978
979

-- | 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
980
981
982
      cm_binds    :: CoreProgram,
      -- | Safe Haskell mode
      cm_safe     :: SafeHaskellMode
983
984
985
    }

instance Outputable CoreModule where