GHC.hs 53.4 KB
Newer Older
1
-- -----------------------------------------------------------------------------
2
--
Gabor Greif's avatar
Gabor Greif committed
3
-- (c) The University of Glasgow, 2005-2012
4 5 6
--
-- The GHC API
--
7
-- -----------------------------------------------------------------------------
8 9

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

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

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

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

        -- ** Compiling to Core
        CoreModule(..),
55
        compileToCoreModule, compileToCoreSimplified,
56

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

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

81 82 83
        -- * Querying the environment
        packageDbModules,

dterei's avatar
dterei committed
84 85
        -- * Printing
        PrintUnqualified, alwaysQualify,
86

dterei's avatar
dterei committed
87 88
        -- * Interactive evaluation
        getBindings, getInsts, getPrintUnqual,
dterei's avatar
dterei committed
89
        findModule, lookupModule,
90
#ifdef GHCI
dterei's avatar
dterei committed
91
        isModuleTrusted,
dterei's avatar
dterei committed
92
        moduleTrustReqs,
dterei's avatar
dterei committed
93 94 95
        setContext, getContext, 
        getNamesInScope,
        getRdrNamesInScope,
96
        getGRE,
dterei's avatar
dterei committed
97 98 99 100 101 102 103
        moduleIsInterpreted,
        getInfo,
        exprType,
        typeKind,
        parseName,
        RunResult(..),  
        runStmt, runStmtWithLocation, runDecls, runDeclsWithLocation,
104
        runTcInteractive,   -- Desired by some clients (Trac #8878)
vivian's avatar
vivian committed
105
        parseImportDecl, SingleStep(..),
106 107 108
        resume,
        Resume(resumeStmt, resumeThreadId, resumeBreakInfo, resumeSpan,
               resumeHistory, resumeHistoryIx),
109
        History(historyBreakInfo, historyEnclosingDecls), 
110
        GHC.getHistorySpan, getHistoryModule,
111 112
        getResumeContext,
        abandon, abandonAll,
113 114
        InteractiveEval.back,
        InteractiveEval.forward,
dterei's avatar
dterei committed
115
        showModule,
116
        isModuleInterpreted,
dterei's avatar
dterei committed
117
        InteractiveEval.compileExpr, HValue, dynCompileExpr,
pepe's avatar
pepe committed
118
        GHC.obtainTermFromId, GHC.obtainTermFromVal, reconstructType,
119
        modInfoModBreaks,
120 121
        ModBreaks(..), BreakIndex,
        BreakInfo(breakInfo_number, breakInfo_module),
122
        BreakArray, setBreakOn, setBreakOff, getBreak,
123
#endif
124
        lookupName,
125

dterei's avatar
dterei committed
126 127 128 129 130
#ifdef GHCI
        -- ** EXPERIMENTAL
        setGHCiMonad,
#endif

dterei's avatar
dterei committed
131
        -- * Abstract syntax elements
132

Simon Marlow's avatar
Simon Marlow committed
133 134 135
        -- ** Packages
        PackageId,

dterei's avatar
dterei committed
136 137
        -- ** Modules
        Module, mkModule, pprModule, moduleName, modulePackageId,
Simon Marlow's avatar
Simon Marlow committed
138
        ModuleName, mkModuleName, moduleNameString,
139

dterei's avatar
dterei committed
140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159
        -- ** Names
        Name, 
        isExternalName, nameModule, pprParenSymName, nameSrcSpan,
        NamedThing(..),
        RdrName(Qual,Unqual),
        
        -- ** Identifiers
        Id, idType,
        isImplicitId, isDeadBinder,
        isExportedId, isLocalId, isGlobalId,
        isRecordSelector,
        isPrimOpId, isFCallId, isClassOpId_maybe,
        isDataConWorkId, idDataCon,
        isBottomingId, isDictonaryId,
        recordSelectorFieldLabel,

        -- ** Type constructors
        TyCon, 
        tyConTyVars, tyConDataCons, tyConArity,
        isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon,
160
        isFamilyTyCon, isOpenFamilyTyCon, tyConClass_maybe,
161
        synTyConRhs_maybe, synTyConDefn_maybe, synTyConResKind,
dterei's avatar
dterei committed
162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179

        -- ** Type variables
        TyVar,
        alphaTyVars,

        -- ** Data constructors
        DataCon,
        dataConSig, dataConType, dataConTyCon, dataConFieldLabels,
        dataConIsInfix, isVanillaDataCon, dataConUserType,
        dataConStrictMarks,  
        StrictnessMark(..), isMarkedStrict,

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

        -- ** Instances
180
        ClsInst, 
dterei's avatar
dterei committed
181
        instanceDFunId, 
182
        pprInstance, pprInstanceHdr,
183
        pprFamInst,
184

185
        FamInst,
186

dterei's avatar
dterei committed
187 188 189 190 191 192
        -- ** Types and Kinds
        Type, splitForAllTys, funResultTy, 
        pprParendType, pprTypeApp, 
        Kind,
        PredType,
        ThetaType, pprForAll, pprThetaArrowTy,
193

dterei's avatar
dterei committed
194 195
        -- ** Entities
        TyThing(..), 
196

dterei's avatar
dterei committed
197 198
        -- ** Syntax
        module HsSyn, -- ToDo: remove extraneous bits
199

dterei's avatar
dterei committed
200 201 202 203 204
        -- ** Fixities
        FixityDirection(..), 
        defaultFixity, maxPrecedence, 
        negateFixity,
        compareFixity,
205

dterei's avatar
dterei committed
206 207
        -- ** Source locations
        SrcLoc(..), RealSrcLoc, 
Ian Lynagh's avatar
Ian Lynagh committed
208
        mkSrcLoc, noSrcLoc,
dterei's avatar
dterei committed
209
        srcLocFile, srcLocLine, srcLocCol,
210
        SrcSpan(..), RealSrcSpan,
Simon Marlow's avatar
Simon Marlow committed
211
        mkSrcSpan, srcLocSpan, isGoodSrcSpan, noSrcSpan,
212
        srcSpanStart, srcSpanEnd,
dterei's avatar
dterei committed
213
        srcSpanFile, 
214 215
        srcSpanStartLine, srcSpanEndLine, 
        srcSpanStartCol, srcSpanEndCol,
216

217
        -- ** Located
dterei's avatar
dterei committed
218
        GenLocated(..), Located,
219

dterei's avatar
dterei committed
220 221
        -- *** Constructing Located
        noLoc, mkGeneralLocated,
222

dterei's avatar
dterei committed
223 224
        -- *** Deconstructing Located
        getLoc, unLoc,
225

dterei's avatar
dterei committed
226 227
        -- *** Combining and comparing Located values
        eqLocated, cmpLocated, combineLocs, addCLoc,
228 229 230
        leftmost_smallest, leftmost_largest, rightmost,
        spans, isSubspanOf,

dterei's avatar
dterei committed
231 232
        -- * Exceptions
        GhcException(..), showGhcException,
233

Jedai's avatar
Jedai committed
234 235 236 237 238
        -- * Token stream manipulations
        Token,
        getTokenStream, getRichTokenStream,
        showRichTokenStream, addSourceToTokens,

239 240 241
        -- * Pure interface to the parser
        parser,

dterei's avatar
dterei committed
242 243 244
        -- * Miscellaneous
        --sessionHscEnv,
        cyclicModuleErr,
245 246
  ) where

247 248 249
{-
 ToDo:

250
  * inline bits of HscMain here to simplify layering: hscTcExpr, hscStmt.
251 252 253 254 255 256
  * what StaticFlags should we expose, if any?
-}

#include "HsVersions.h"

#ifdef GHCI
257
import ByteCodeInstr
258
import BreakArray
259
import InteractiveEval
260
import TcRnDriver       ( runTcInteractive )
261 262
#endif

263
import HscMain
264
import GhcMake
265
import DriverPipeline   ( compileOne' )
266
import GhcMonad
267
import TcRnMonad        ( finalSafeMode )
268
import TcRnTypes
269 270 271
import Packages
import NameSet
import RdrName
Ian Lynagh's avatar
Ian Lynagh committed
272
import qualified HsSyn -- hack as we want to reexport the whole module
273
import HsSyn
batterseapower's avatar
batterseapower committed
274
import Type     hiding( typeKind )
dterei's avatar
dterei committed
275 276
import Kind             ( synTyConResKind )
import TcType           hiding( typeKind )
277
import Id
dterei's avatar
dterei committed
278
import TysPrim          ( alphaTyVars )
279 280 281 282
import TyCon
import Class
import DataCon
import Name             hiding ( varName )
283
import Avail
284
import InstEnv
285
import FamInstEnv
286
import SrcLoc
287
import CoreSyn
288
import TidyPgm
289
import DriverPhases     ( Phase(..), isHaskellSrcFilename )
290 291 292
import Finder
import HscTypes
import DynFlags
293
import StaticFlags
294
import SysTools
295
import Annotations
296
import Module
297
import UniqFM
298
import Panic
299
import Platform
dterei's avatar
dterei committed
300
import Bag              ( unitBag )
301
import ErrUtils
302
import MonadUtils
303
import Util
304
import StringBuffer
305
import Outputable
306
import BasicTypes
dterei's avatar
dterei committed
307
import Maybes           ( expectJust )
308
import FastString
309
import qualified Parser
Jedai's avatar
Jedai committed
310
import Lexer
311

Austin Seipp's avatar
Austin Seipp committed
312
import System.Directory ( doesFileExist )
313
import Data.Maybe
dterei's avatar
dterei committed
314
import Data.List        ( find )
315
import Data.Time
316 317
import Data.Typeable    ( Typeable )
import Data.Word        ( Word8 )
318
import Control.Monad
dterei's avatar
dterei committed
319
import System.Exit      ( exitWith, ExitCode(..) )
320
import Exception
321
import Data.IORef
Ian Lynagh's avatar
Ian Lynagh committed
322
import System.FilePath
323
import System.IO
324
import Prelude hiding (init)
325

326

327
-- %************************************************************************
dterei's avatar
dterei committed
328
-- %*                                                                      *
329
--             Initialisation: exception handlers
dterei's avatar
dterei committed
330
-- %*                                                                      *
331 332
-- %************************************************************************

333 334 335 336 337

-- | 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.
338
defaultErrorHandler :: (ExceptionMonad m, MonadIO m)
Ian Lynagh's avatar
Ian Lynagh committed
339 340
                    => FatalMessager -> FlushOut -> m a -> m a
defaultErrorHandler fm (FlushOut flushOut) inner =
341
  -- top-level exception handler: any unrecognised exception is a compiler bug.
342
  ghandle (\exception -> liftIO $ do
343
           flushOut
344
           case fromException exception of
345 346
                -- an IO exception probably isn't our fault, so don't panic
                Just (ioe :: IOException) ->
Ian Lynagh's avatar
Ian Lynagh committed
347
                  fatalErrorMsg'' fm (show ioe)
348
                _ -> case fromException exception of
349 350 351 352
                     Just UserInterrupt ->
                         -- Important to let this one propagate out so our
                         -- calling process knows we were interrupted by ^C
                         liftIO $ throwIO UserInterrupt
353
                     Just StackOverflow ->
Ian Lynagh's avatar
Ian Lynagh committed
354
                         fatalErrorMsg'' fm "stack overflow: use +RTS -K<size> to increase it"
355
                     _ -> case fromException exception of
356
                          Just (ex :: ExitCode) -> liftIO $ throwIO ex
357
                          _ ->
Ian Lynagh's avatar
Ian Lynagh committed
358 359
                              fatalErrorMsg'' fm
                                  (show (Panic (show exception)))
360
           exitWith (ExitFailure 1)
361 362
         ) $

363
  -- error messages propagated as exceptions
364
  handleGhcException
365
            (\ge -> liftIO $ do
366
                flushOut
dterei's avatar
dterei committed
367 368 369
                case ge of
                     PhaseFailed _ code -> exitWith code
                     Signal _ -> exitWith (ExitFailure 1)
Ian Lynagh's avatar
Ian Lynagh committed
370
                     _ -> do fatalErrorMsg'' fm (show ge)
dterei's avatar
dterei committed
371 372
                             exitWith (ExitFailure 1)
            ) $
373 374
  inner

375
-- | Install a default cleanup handler to remove temporary files deposited by
Gabor Greif's avatar
Gabor Greif committed
376
-- a GHC run.  This is separate from 'defaultErrorHandler', because you might
377 378 379 380 381
-- want to override the error handling, but still get the ordinary cleanup
-- behaviour.
defaultCleanupHandler :: (ExceptionMonad m, MonadIO m) =>
                         DynFlags -> m a -> m a
defaultCleanupHandler dflags inner =
382
    -- make sure we clean up after ourselves
383
    inner `gfinally`
384 385
          (liftIO $ do
              cleanTempFiles dflags
386
              cleanTempDirs dflags
387
          )
388
          --  exceptions will be blocked while we clean the temporary files,
389 390
          -- so there shouldn't be any difficulty if we receive further
          -- signals.
391

392

393
-- %************************************************************************
dterei's avatar
dterei committed
394
-- %*                                                                      *
395
--             The Ghc Monad
dterei's avatar
dterei committed
396
-- %*                                                                      *
397
-- %************************************************************************
398 399 400 401 402 403 404 405 406 407 408 409 410 411

-- | 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
412
  ref <- newIORef (panic "empty session")
413
  let session = Session ref
414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429
  flip unGhc session $ do
    initGhcMonad mb_top_dir
    ghc
  -- XXX: unregister interrupt handlers here?

-- | Run function for 'GhcT' monad transformer.
--
-- It initialises the GHC session and warnings via 'initGhcMonad'.  Each call
-- to this function will create a new session which should not be shared among
-- several threads.

runGhcT :: (ExceptionMonad m, Functor m, MonadIO m) =>
           Maybe FilePath  -- ^ See argument to 'initGhcMonad'.
        -> GhcT m a        -- ^ The action to perform.
        -> m a
runGhcT mb_top_dir ghct = do
430
  ref <- liftIO $ newIORef (panic "empty session")
431
  let session = Session ref
432 433 434 435 436 437 438 439 440 441 442 443 444 445
  flip unGhcT session $ do
    initGhcMonad mb_top_dir
    ghct

-- | Initialise a GHC session.
--
-- If you implement a custom 'GhcMonad' you must call this function in the
-- monad run function.  It will initialise the session variable and clear all
-- warnings.
--
-- The first argument should point to the directory where GHC's library files
-- reside.  More precisely, this should be the output of @ghc --print-libdir@
-- of the version of GHC the module using this API is compiled with.  For
-- portability, you should use the @ghc-paths@ package, available at
446
-- <http://hackage.haskell.org/package/ghc-paths>.
447 448

initGhcMonad :: GhcMonad m => Maybe FilePath -> m ()
449 450 451 452 453 454
initGhcMonad mb_top_dir
  = do { env <- liftIO $
                do { installSignalHandlers  -- catch ^C
                   ; initStaticOpts
                   ; mySettings <- initSysTools mb_top_dir
                   ; dflags <- initDynFlags (defaultDynFlags mySettings)
455
                   ; checkBrokenTablesNextToCode dflags
456 457 458 459 460
                   ; setUnsafeGlobalDynFlags dflags
                      -- c.f. DynFlags.parseDynamicFlagsFull, which
                      -- creates DynFlags and sets the UnsafeGlobalDynFlags
                   ; newHscEnv dflags }
       ; setSession env }
461

462 463 464 465 466 467 468 469 470 471
-- | 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
472
         $ do { _ <- liftIO $ throwIO $ mkApiErr dflags invalidLdErr
473 474 475
              ; fail "unsupported linker"
              }
       }
476 477 478 479
  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)"
480 481 482 483 484 485 486 487 488 489 490 491 492 493

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

494 495

-- %************************************************************************
dterei's avatar
dterei committed
496
-- %*                                                                      *
497
--             Flags & settings
dterei's avatar
dterei committed
498
-- %*                                                                      *
499
-- %************************************************************************
500

501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527
-- $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).
528 529 530 531 532 533
--
-- 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.
--
534 535 536
setSessionDynFlags :: GhcMonad m => DynFlags -> m [PackageId]
setSessionDynFlags dflags = do
  (dflags', preload) <- liftIO $ initPackages dflags
537 538
  modifySession $ \h -> h{ hsc_dflags = dflags'
                         , hsc_IC = (hsc_IC h){ ic_dflags = dflags' } }
539
  invalidateModSummaryCache
540 541 542 543 544 545 546
  return preload

-- | Sets the program 'DynFlags'.
setProgramDynFlags :: GhcMonad m => DynFlags -> m [PackageId]
setProgramDynFlags dflags = do
  (dflags', preload) <- liftIO $ initPackages dflags
  modifySession $ \h -> h{ hsc_dflags = dflags' }
547
  invalidateModSummaryCache
548
  return preload
549

550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574
-- 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) }

575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590
-- | 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
  modifySession $ \h -> h{ hsc_IC = (hsc_IC h) { ic_dflags = dflags }}

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

591

592
parseDynamicFlags :: MonadIO m =>
593 594 595 596
                     DynFlags -> [Located String]
                  -> m (DynFlags, [Located String], [Located String])
parseDynamicFlags = parseDynamicFlagsCmdLine

597 598

-- %************************************************************************
dterei's avatar
dterei committed
599
-- %*                                                                      *
600
--             Setting, getting, and modifying the targets
dterei's avatar
dterei committed
601
-- %*                                                                      *
602
-- %************************************************************************
603 604 605 606 607 608

-- 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
609
-- the program\/library.  Unloading the current program is achieved by
610 611 612
-- 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 })
613

614 615 616
-- | Returns the current set of targets
getTargets :: GhcMonad m => m [Target]
getTargets = withSession (return . hsc_targets)
617

618 619 620 621
-- | Add another target.
addTarget :: GhcMonad m => Target -> m ()
addTarget target
  = modifySession (\h -> h{ hsc_targets = target : hsc_targets h })
622

623
-- | Remove a target
624 625 626
removeTarget :: GhcMonad m => TargetId -> m ()
removeTarget target_id
  = modifySession (\h -> h{ hsc_targets = filter (hsc_targets h) })
627
  where
Simon Marlow's avatar
Simon Marlow committed
628
   filter targets = [ t | t@(Target id _ _) <- targets, id /= target_id ]
629

630 631 632 633 634 635 636 637
-- | 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
638
--
639
--   - otherwise interpret the string as a module name
640
--
641
guessTarget :: GhcMonad m => String -> Maybe Phase -> m Target
Simon Marlow's avatar
Simon Marlow committed
642 643 644
guessTarget str (Just phase)
   = return (Target (TargetFile str (Just phase)) True Nothing)
guessTarget str Nothing
645
   | isHaskellSrcFilename file
Simon Marlow's avatar
Simon Marlow committed
646
   = return (target (TargetFile file Nothing))
647
   | otherwise
648
   = do exists <- liftIO $ doesFileExist hs_file
dterei's avatar
dterei committed
649 650 651 652 653 654 655
        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
656 657 658
        if looksLikeModuleName file
           then return (target (TargetModule (mkModuleName file)))
           else do
Ian Lynagh's avatar
Ian Lynagh committed
659
        dflags <- getDynFlags
660
        liftIO $ throwGhcExceptionIO
Ian Lynagh's avatar
Ian Lynagh committed
661
                 (ProgramError (showSDoc dflags $
662 663
                 text "target" <+> quotes (text file) <+> 
                 text "is not a module name or a source file"))
664
     where 
Simon Marlow's avatar
Simon Marlow committed
665 666 667 668
         (file,obj_allowed)
                | '*':rest <- str = (rest, False)
                | otherwise       = (str,  True)

dterei's avatar
dterei committed
669 670
         hs_file  = file <.> "hs"
         lhs_file = file <.> "lhs"
671

Simon Marlow's avatar
Simon Marlow committed
672 673
         target tid = Target tid obj_allowed Nothing

674

675 676 677 678 679 680 681 682 683
-- | Inform GHC that the working directory has changed.  GHC will flush
-- its cache of module locations, since it may no longer be valid.
-- 
-- Note: Before changing the working directory make sure all threads running
-- in the same session have stopped.  If you change the working directory,
-- you should also unload the current program (set targets to empty,
-- followed by load).
workingDirectoryChanged :: GhcMonad m => m ()
workingDirectoryChanged = withSession $ (liftIO . flushFinderCaches)
684

685 686

-- %************************************************************************
dterei's avatar
dterei committed
687
-- %*                                                                      *
688
--             Running phases one at a time
dterei's avatar
dterei committed
689
-- %*                                                                      *
690
-- %************************************************************************
691 692 693 694 695 696 697 698 699 700

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
701 702 703 704 705
        -- 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.
706 707 708 709 710 711 712

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

-- | The result of successful parsing.
data ParsedModule =
  ParsedModule { pm_mod_summary   :: ModSummary
713 714
               , pm_parsed_source :: ParsedSource
               , pm_extra_src_files :: [FilePath] }
715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736

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
737
  moduleInfo m        = tm_checked_module_info m
738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758
  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
759

760
type ParsedSource      = Located (HsModule RdrName)
761
type RenamedSource     = (HsGroup Name, [LImportDecl Name], Maybe [LIE Name],
762
                          Maybe LHsDocString)
763 764
type TypecheckedSource = LHsBinds Id

765 766 767 768 769 770 771 772 773 774 775 776
-- 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

777 778 779
-- | Return the 'ModSummary' of a module with the given name.
--
-- The module must be part of the module graph (see 'hsc_mod_graph' and
780
-- 'ModuleGraph').  If this is not the case, this function will throw a
781 782
-- 'GhcApiError'.
--
783 784
-- This function ignores boot modules and requires that there is only one
-- non-boot module with the given name.
785 786 787
getModSummary :: GhcMonad m => ModuleName -> m ModSummary
getModSummary mod = do
   mg <- liftM hsc_mod_graph getSession
788
   case [ ms | ms <- mg, ms_mod_name ms == mod, not (isBootSummary ms) ] of
789
     [] -> do dflags <- getDynFlags
790
              liftIO $ throwIO $ mkApiErr dflags (text "Module not part of module graph")
791
     [ms] -> return ms
792
     multiple -> do dflags <- getDynFlags
793
                    liftIO $ throwIO $ mkApiErr dflags (text "getModSummary is ambiguous: " <+> ppr multiple)
794 795 796 797

-- | Parse a module.
--
-- Throws a 'SourceError' on parse error.
798 799
parseModule :: GhcMonad m => ModSummary -> m ParsedModule
parseModule ms = do
800 801
   hsc_env <- getSession
   let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }
802 803
   hpm <- liftIO $ hscParse hsc_env_tmp ms
   return (ParsedModule ms (hpm_module hpm) (hpm_src_files hpm))
804 805 806 807 808 809

-- | Typecheck and rename a parsed module.
--
-- Throws a 'SourceError' if either fails.
typecheckModule :: GhcMonad m => ParsedModule -> m TypecheckedModule
typecheckModule pmod = do
810
 let ms = modSummary pmod
811 812 813
 hsc_env <- getSession
 let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }
 (tc_gbl_env, rn_info)
814 815 816
       <- liftIO $ hscTypecheckRename hsc_env_tmp ms $
                      HsParsedModule { hpm_module = parsedSource pmod,
                                       hpm_src_files = pm_extra_src_files pmod }
817
 details <- liftIO $ makeSimpleDetails hsc_env_tmp tc_gbl_env
818
 safe    <- liftIO $ finalSafeMode (ms_hspp_opts ms) tc_gbl_env
819
 return $
820 821 822 823 824 825 826 827 828 829
     TypecheckedModule {
       tm_internals_          = (tc_gbl_env, details),
       tm_parsed_module       = pmod,
       tm_renamed_source      = rn_info,
       tm_typechecked_source  = tcg_binds tc_gbl_env,
       tm_checked_module_info =
         ModuleInfo {
           minf_type_env  = md_types details,
           minf_exports   = availsToNameSet $ md_exports details,
           minf_rdr_env   = Just (tcg_rdr_env tc_gbl_env),
830
           minf_instances = md_insts details,
831 832
           minf_iface     = Nothing,
           minf_safe      = safe
mnislaih's avatar
mnislaih committed
833
#ifdef GHCI
834
          ,minf_modBreaks = emptyModBreaks
mnislaih's avatar
mnislaih committed
835
#endif
836 837 838 839 840
         }}

-- | Desugar a typechecked module.
desugarModule :: GhcMonad m => TypecheckedModule -> m DesugaredModule
desugarModule tcm = do
841
 let ms = modSummary tcm
842 843 844 845 846
 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 $
847 848 849 850 851 852 853
     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
854 855 856 857 858 859 860
-- 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).
--
861 862 863 864
loadModule :: (TypecheckedMod mod, GhcMonad m) => mod -> m mod
loadModule tcm = do
   let ms = modSummary tcm
   let mod = ms_mod_name ms
865
   let loc = ms_location ms
866 867
   let (tcg, _details) = tm_internals tcm

868
   mb_linkable <- case ms_obj_date ms of
869 870 871 872 873 874
                     Just t | t > ms_hs_date ms  -> do
                         l <- liftIO $ findObjectLinkable (ms_mod ms) 
                                                  (ml_obj_file loc) t
                         return (Just l)
                     _otherwise -> return Nothing
                                                
875 876 877 878
   let source_modified | isNothing mb_linkable = SourceModified
                       | otherwise             = SourceUnmodified
                       -- we can't determine stability here

879 880
   -- compile doesn't change the session
   hsc_env <- getSession
881 882 883
   mod_info <- liftIO $ compileOne' (Just tcg) Nothing
                                    hsc_env ms 1 1 Nothing mb_linkable
                                    source_modified
884 885

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

888 889

-- %************************************************************************
dterei's avatar
dterei committed
890
-- %*                                                                      *
891
--             Dealing with Core
dterei's avatar
dterei committed
892
-- %*                                                                      *
893
-- %************************************************************************
894 895 896 897 898 899 900 901 902 903

-- | 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
904 905 906
      cm_binds    :: CoreProgram,
      -- | Safe Haskell mode
      cm_safe     :: SafeHaskellMode
907 908 909
    }

instance Outputable CoreModule where
910 911 912 913
   ppr (CoreModule {cm_module = mn, cm_types = te, cm_binds = cb,
                    cm_safe = sf})
    = text "%module" <+> ppr mn <+> parens (ppr sf) <+> ppr te
      $$ vcat (map ppr cb)
914

915
-- | This is the way to get access to the Core bindings corresponding
916 917
-- to a module. 'compileToCore' parses, typechecks, and
-- desugars the module, then returns the resulting Core module (consisting of
918 919
-- the module name, type declarations, and function declarations) if
-- successful.
920
compileToCoreModule :: GhcMonad m => FilePath -> m CoreModule
921 922 923 924
compileToCoreModule = compileCore False

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

928 929
compileCore :: GhcMonad m => Bool -> FilePath -> m CoreModule
compileCore simplify fn = do
930 931
   -- First, set the target to the desired filename
   target <- guessTarget fn Nothing
932
   addTarget target
933
   _ <- load LoadAllTargets
934
   -- Then find dependencies
935 936 937 938 939 940
   modGraph <- depanal [] True
   case find ((== fn) . msHsFilePath) modGraph of
     Just modSummary -> do
       -- Now we have the module name;
       -- parse, typecheck and desugar the module
       mod_guts <- coreModule `fmap`
941
                      -- TODO: space leaky: call hsc* directly?
942
                      (desugarModule =<< typecheckModule =<< parseModule modSummary)
943
       liftM (gutsToCoreModule (mg_safe_haskell mod_guts)) $
944 945 946 947 948
         if simplify
          then do
             -- If simplify is true: simplify (hscSimplify), then tidy
             -- (tidyProgram).
             hsc_env <- getSession
949
             simpl_guts <- liftIO $ hscSimplify hsc_env mod_guts
950 951 952 953 954 955
             tidy_guts <- liftIO $ tidyProgram hsc_env simpl_guts
             return $ Left tidy_guts
          else
             return $ Right mod_guts

     Nothing -> panic "compileToCoreModule: target FilePath not found in\
956
                           module dependency graph"
957 958 959
  where -- two versions, based on whether we simplify (thus run tidyProgram,
        -- which returns a (CgGuts, ModDetails) pair, or not (in which case
        -- we just have a ModGuts.
960 961 962 963
        gutsToCoreModule :: SafeHaskellMode
                         -> Either (CgGuts, ModDetails) ModGuts
                         -> CoreModule
        gutsToCoreModule safe_mode (Left (cg, md)) = CoreModule {
964
          cm_module = cg_module cg,
965 966 967
          cm_types  = md_types md,
          cm_binds  = cg_binds cg,
          cm_safe   = safe_mode
968
        }
969
        gutsToCoreModule safe_mode (Right mg) = CoreModule {
970 971
          cm_module  = mg_module mg,
          cm_types   = typeEnvFromEntities (bindersOfBinds (mg_binds mg))
dreixel's avatar
dreixel committed
972
                                           (mg_tcs mg)
973
                                           (mg_fam_insts mg),
974 975
          cm_binds   = mg_binds mg,
          cm_safe    = safe_mode
976
         }
977

978
-- %************************************************************************
dterei's avatar
dterei committed
979
-- %*                                                                      *
980
--             Inspecting the session
dterei's avatar
dterei committed
981
-- %*                                                                      *
982
-- %************************************************************************
983

984
-- | Get the module dependency graph.
985 986
getModuleGraph :: GhcMonad m => m ModuleGraph -- ToDo: DiGraph ModSummary
getModuleGraph = liftM hsc_mod_graph getSession
987

988 989 990 991 992 993 994
-- | Determines whether a set of modules requires Template Haskell.
--
-- Note that if the session's 'DynFlags' enabled Template Haskell when
-- 'depanal' was called, then each module in the returned module graph will
-- have Template Haskell enabled whether it is actually needed or not.
needsTemplateHaskell :: ModuleGraph -> Bool
needsTemplateHaskell ms =
995
    any (xopt Opt_TemplateHaskell . ms_hspp_opts) ms
996

997 998 999
-- | Return @True@ <==> module is loaded.
isLoaded :: GhcMonad m => ModuleName -> m Bool
isLoaded m = withSession $ \hsc_env ->
Simon Marlow's avatar
Simon Marlow committed
1000
  return $! isJust (lookupUFM (hsc_HPT hsc_env) m)
1001

1002 1003 1004
-- | Return the bindings for the current interactive session.
getBindings :: GhcMonad m => m [TyThing]
getBindings = withSession $ \hsc_env ->
1005 1006 1007
    return $ icInScopeTTs $ hsc_IC hsc_env

-- | Return the instances for the current interactive session.
1008
getInsts :: GhcMonad m => m ([ClsInst], [FamInst])
1009 1010
getInsts = withSession $ \hsc_env ->
    return $ ic_instances (hsc_IC hsc_env)
1011

1012 1013
getPrintUnqual :: GhcMonad m => m PrintUnqualified
getPrintUnqual = withSession $ \hsc_env ->
1014
  return (icPrintUnqual (hsc_dflags hsc_env) (hsc_IC hsc_env))
1015

1016
-- | Container for information about a 'Module'.
1017
data ModuleInfo = ModuleInfo {
dterei's avatar
dterei committed
1018 1019 1020
        minf_type_env  :: TypeEnv,
        minf_exports   :: NameSet, -- ToDo, [AvailInfo] like ModDetails?
        minf_rdr_env   :: Maybe GlobalRdrEnv,   -- Nothing for a compiled/package mod
1021
        minf_instances :: [ClsInst],
1022 1023
        minf_iface     :: Maybe ModIface,
        minf_safe      :: SafeHaskellMode
mnislaih's avatar
mnislaih committed
1024
#ifdef GHCI
1025
       ,minf_modBreaks :: ModBreaks
mnislaih's avatar
mnislaih committed
1026
#endif
1027
  }
dterei's avatar
dterei committed
1028 1029
        -- We don't want HomeModInfo here, because a ModuleInfo applies
        -- to package modules too.
1030 1031

-- | Request information about a loaded 'Module'
1032 1033
getModuleInfo :: GhcMonad m => Module -> m (Maybe ModuleInfo)  -- XXX: Maybe X
getModuleInfo mdl = withSession $ \hsc_env -> do
1034 1035
  let mg = hsc_mod_graph hsc_env
  if mdl `elem` map ms_mod mg
dterei's avatar
dterei committed
1036 1037
        then liftIO $ getHomeModuleInfo hsc_env mdl
        else do
1038
  {- if isHomeModule (hsc_dflags hsc_env) mdl
dterei's avatar
dterei committed
1039 1040
        then return Nothing
        else -} liftIO $ getPackageModuleInfo hsc_env mdl
1041 1042
   -- ToDo: we don't understand what the following comment means.
   --    (SDM, 19/7/2011)
1043 1044 1045 1046
   -- getPackageModuleInfo will attempt to find the interface, so
   -- we don't want to call it for a home module, just in case there
   -- was a problem loading the module and the interface doesn't
   -- exist... hence the isHomeModule test here.  (ToDo: reinstate)
1047 1048

getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
1049
#ifdef GHCI
1050
getPackageModuleInfo hsc_env mdl 
dterei's avatar
dterei committed
1051
  = do  eps <- hscEPS hsc_env
1052
        iface <- hscGetModuleInterface hsc_env mdl
dterei's avatar
dterei committed
1053 1054
        let 
            avails = mi_exports iface
1055
            names  = availsToNameSet avails
dterei's avatar
dterei committed
1056 1057 1058 1059 1060 1061 1062 1063 1064
            pte    = eps_PTE eps
            tys    = [ ty | name <- concatMap availNames avails,
                            Just ty <- [lookupTypeEnv pte name] ]
        --
        return (Just (ModuleInfo {
                        minf_type_env  = mkTypeEnv tys,
                        minf_exports   = names,
                        minf_rdr_env   = Just $! availsToGlobalRdrEnv (moduleName mdl) avails,
                        minf_instances = error "getModuleInfo: instances for package module unimplemented",
1065
                        minf_iface     = Just iface,
1066
                        minf_safe      = getSafeMode $ mi_trust iface,
1067
                        minf_modBreaks = emptyModBreaks