Add dump flag for timing output
[ghc.git] / compiler / main / GHC.hs
1 {-# LANGUAGE CPP, NondecreasingIndentation, ScopedTypeVariables #-}
2 {-# LANGUAGE TupleSections, NamedFieldPuns #-}
3
4 -- -----------------------------------------------------------------------------
5 --
6 -- (c) The University of Glasgow, 2005-2012
7 --
8 -- The GHC API
9 --
10 -- -----------------------------------------------------------------------------
11
12 module GHC (
13 -- * Initialisation
14 defaultErrorHandler,
15 defaultCleanupHandler,
16 prettyPrintGhcErrors,
17 withSignalHandlers,
18 withCleanupSession,
19
20 -- * GHC Monad
21 Ghc, GhcT, GhcMonad(..), HscEnv,
22 runGhc, runGhcT, initGhcMonad,
23 gcatch, gbracket, gfinally,
24 printException,
25 handleSourceError,
26 needsTemplateHaskellOrQQ,
27
28 -- * Flags and settings
29 DynFlags(..), GeneralFlag(..), Severity(..), HscTarget(..), gopt,
30 GhcMode(..), GhcLink(..), defaultObjectTarget,
31 parseDynamicFlags,
32 getSessionDynFlags, setSessionDynFlags,
33 getProgramDynFlags, setProgramDynFlags, setLogAction,
34 getInteractiveDynFlags, setInteractiveDynFlags,
35
36 -- * Targets
37 Target(..), TargetId(..), Phase,
38 setTargets,
39 getTargets,
40 addTarget,
41 removeTarget,
42 guessTarget,
43
44 -- * Loading\/compiling the program
45 depanal,
46 load, LoadHowMuch(..), InteractiveImport(..),
47 SuccessFlag(..), succeeded, failed,
48 defaultWarnErrLogger, WarnErrLogger,
49 workingDirectoryChanged,
50 parseModule, typecheckModule, desugarModule, loadModule,
51 ParsedModule(..), TypecheckedModule(..), DesugaredModule(..),
52 TypecheckedSource, ParsedSource, RenamedSource, -- ditto
53 TypecheckedMod, ParsedMod,
54 moduleInfo, renamedSource, typecheckedSource,
55 parsedSource, coreModule,
56
57 -- ** Compiling to Core
58 CoreModule(..),
59 compileToCoreModule, compileToCoreSimplified,
60
61 -- * Inspecting the module structure of the program
62 ModuleGraph, emptyMG, mapMG, mkModuleGraph, mgModSummaries,
63 mgLookupModule,
64 ModSummary(..), ms_mod_name, ModLocation(..),
65 getModSummary,
66 getModuleGraph,
67 isLoaded,
68 topSortModuleGraph,
69
70 -- * Inspecting modules
71 ModuleInfo,
72 getModuleInfo,
73 modInfoTyThings,
74 modInfoTopLevelScope,
75 modInfoExports,
76 modInfoExportsWithSelectors,
77 modInfoInstances,
78 modInfoIsExportedName,
79 modInfoLookupName,
80 modInfoIface,
81 modInfoSafe,
82 lookupGlobalName,
83 findGlobalAnns,
84 mkPrintUnqualifiedForModule,
85 ModIface(..),
86 SafeHaskellMode(..),
87
88 -- * Querying the environment
89 -- packageDbModules,
90
91 -- * Printing
92 PrintUnqualified, alwaysQualify,
93
94 -- * Interactive evaluation
95
96 -- ** Executing statements
97 execStmt, ExecOptions(..), execOptions, ExecResult(..),
98 resumeExec,
99
100 -- ** Adding new declarations
101 runDecls, runDeclsWithLocation,
102
103 -- ** Get/set the current context
104 parseImportDecl,
105 setContext, getContext,
106 setGHCiMonad, getGHCiMonad,
107
108 -- ** Inspecting the current context
109 getBindings, getInsts, getPrintUnqual,
110 findModule, lookupModule,
111 isModuleTrusted, moduleTrustReqs,
112 getNamesInScope,
113 getRdrNamesInScope,
114 getGRE,
115 moduleIsInterpreted,
116 getInfo,
117 showModule,
118 moduleIsBootOrNotObjectLinkable,
119 getNameToInstancesIndex,
120
121 -- ** Inspecting types and kinds
122 exprType, TcRnExprMode(..),
123 typeKind,
124
125 -- ** Looking up a Name
126 parseName,
127 lookupName,
128
129 -- ** Compiling expressions
130 HValue, parseExpr, compileParsedExpr,
131 InteractiveEval.compileExpr, dynCompileExpr,
132 ForeignHValue,
133 compileExprRemote, compileParsedExprRemote,
134
135 -- ** Other
136 runTcInteractive, -- Desired by some clients (Trac #8878)
137 isStmt, hasImport, isImport, isDecl,
138
139 -- ** The debugger
140 SingleStep(..),
141 Resume(..),
142 History(historyBreakInfo, historyEnclosingDecls),
143 GHC.getHistorySpan, getHistoryModule,
144 abandon, abandonAll,
145 getResumeContext,
146 GHC.obtainTermFromId, GHC.obtainTermFromVal, reconstructType,
147 modInfoModBreaks,
148 ModBreaks(..), BreakIndex,
149 BreakInfo(breakInfo_number, breakInfo_module),
150 InteractiveEval.back,
151 InteractiveEval.forward,
152
153 -- * Abstract syntax elements
154
155 -- ** Packages
156 UnitId,
157
158 -- ** Modules
159 Module, mkModule, pprModule, moduleName, moduleUnitId,
160 ModuleName, mkModuleName, moduleNameString,
161
162 -- ** Names
163 Name,
164 isExternalName, nameModule, pprParenSymName, nameSrcSpan,
165 NamedThing(..),
166 RdrName(Qual,Unqual),
167
168 -- ** Identifiers
169 Id, idType,
170 isImplicitId, isDeadBinder,
171 isExportedId, isLocalId, isGlobalId,
172 isRecordSelector,
173 isPrimOpId, isFCallId, isClassOpId_maybe,
174 isDataConWorkId, idDataCon,
175 isBottomingId, isDictonaryId,
176 recordSelectorTyCon,
177
178 -- ** Type constructors
179 TyCon,
180 tyConTyVars, tyConDataCons, tyConArity,
181 isClassTyCon, isTypeSynonymTyCon, isTypeFamilyTyCon, isNewTyCon,
182 isPrimTyCon, isFunTyCon,
183 isFamilyTyCon, isOpenFamilyTyCon, isOpenTypeFamilyTyCon,
184 tyConClass_maybe,
185 synTyConRhs_maybe, synTyConDefn_maybe, tyConKind,
186
187 -- ** Type variables
188 TyVar,
189 alphaTyVars,
190
191 -- ** Data constructors
192 DataCon,
193 dataConSig, dataConType, dataConTyCon, dataConFieldLabels,
194 dataConIsInfix, isVanillaDataCon, dataConUserType,
195 dataConSrcBangs,
196 StrictnessMark(..), isMarkedStrict,
197
198 -- ** Classes
199 Class,
200 classMethods, classSCTheta, classTvsFds, classATs,
201 pprFundeps,
202
203 -- ** Instances
204 ClsInst,
205 instanceDFunId,
206 pprInstance, pprInstanceHdr,
207 pprFamInst,
208
209 FamInst,
210
211 -- ** Types and Kinds
212 Type, splitForAllTys, funResultTy,
213 pprParendType, pprTypeApp,
214 Kind,
215 PredType,
216 ThetaType, pprForAll, pprThetaArrowTy,
217
218 -- ** Entities
219 TyThing(..),
220
221 -- ** Syntax
222 module HsSyn, -- ToDo: remove extraneous bits
223
224 -- ** Fixities
225 FixityDirection(..),
226 defaultFixity, maxPrecedence,
227 negateFixity,
228 compareFixity,
229 LexicalFixity(..),
230
231 -- ** Source locations
232 SrcLoc(..), RealSrcLoc,
233 mkSrcLoc, noSrcLoc,
234 srcLocFile, srcLocLine, srcLocCol,
235 SrcSpan(..), RealSrcSpan,
236 mkSrcSpan, srcLocSpan, isGoodSrcSpan, noSrcSpan,
237 srcSpanStart, srcSpanEnd,
238 srcSpanFile,
239 srcSpanStartLine, srcSpanEndLine,
240 srcSpanStartCol, srcSpanEndCol,
241
242 -- ** Located
243 GenLocated(..), Located,
244
245 -- *** Constructing Located
246 noLoc, mkGeneralLocated,
247
248 -- *** Deconstructing Located
249 getLoc, unLoc,
250
251 -- *** Combining and comparing Located values
252 eqLocated, cmpLocated, combineLocs, addCLoc,
253 leftmost_smallest, leftmost_largest, rightmost,
254 spans, isSubspanOf,
255
256 -- * Exceptions
257 GhcException(..), showGhcException,
258
259 -- * Token stream manipulations
260 Token,
261 getTokenStream, getRichTokenStream,
262 showRichTokenStream, addSourceToTokens,
263
264 -- * Pure interface to the parser
265 parser,
266
267 -- * API Annotations
268 ApiAnns,AnnKeywordId(..),AnnotationComment(..),
269 getAnnotation, getAndRemoveAnnotation,
270 getAnnotationComments, getAndRemoveAnnotationComments,
271 unicodeAnn,
272
273 -- * Miscellaneous
274 --sessionHscEnv,
275 cyclicModuleErr,
276 ) where
277
278 {-
279 ToDo:
280
281 * inline bits of HscMain here to simplify layering: hscTcExpr, hscStmt.
282 -}
283
284 #include "HsVersions.h"
285
286 import GhcPrelude hiding (init)
287
288 import ByteCodeTypes
289 import InteractiveEval
290 import InteractiveEvalTypes
291 import TcRnDriver ( runTcInteractive )
292 import GHCi
293 import GHCi.RemoteTypes
294
295 import PprTyThing ( pprFamInst )
296 import HscMain
297 import GhcMake
298 import DriverPipeline ( compileOne' )
299 import GhcMonad
300 import TcRnMonad ( finalSafeMode, fixSafeInstances )
301 import TcRnTypes
302 import Packages
303 import NameSet
304 import RdrName
305 import HsSyn
306 import Type hiding( typeKind )
307 import TcType hiding( typeKind )
308 import Id
309 import TysPrim ( alphaTyVars )
310 import TyCon
311 import Class
312 import DataCon
313 import Name hiding ( varName )
314 import Avail
315 import InstEnv
316 import FamInstEnv ( FamInst )
317 import SrcLoc
318 import CoreSyn
319 import TidyPgm
320 import DriverPhases ( Phase(..), isHaskellSrcFilename )
321 import Finder
322 import HscTypes
323 import CmdLineParser
324 import DynFlags hiding (WarnReason(..))
325 import SysTools
326 import Annotations
327 import Module
328 import Panic
329 import Platform
330 import Bag ( listToBag, unitBag )
331 import ErrUtils
332 import MonadUtils
333 import Util
334 import StringBuffer
335 import Outputable
336 import BasicTypes
337 import Maybes ( expectJust )
338 import FastString
339 import qualified Parser
340 import Lexer
341 import ApiAnnotation
342 import qualified GHC.LanguageExtensions as LangExt
343 import NameEnv
344 import CoreFVs ( orphNamesOfFamInst )
345 import FamInstEnv ( famInstEnvElts )
346 import TcRnDriver
347 import Inst
348 import FamInst
349 import FileCleanup
350
351 import Data.Foldable
352 import qualified Data.Map.Strict as Map
353 import Data.Set (Set)
354 import qualified Data.Sequence as Seq
355 import System.Directory ( doesFileExist )
356 import Data.Maybe
357 import Data.List ( find )
358 import Data.Time
359 import Data.Typeable ( Typeable )
360 import Data.Word ( Word8 )
361 import Control.Monad
362 import System.Exit ( exitWith, ExitCode(..) )
363 import Exception
364 import Data.IORef
365 import System.FilePath
366
367
368 -- %************************************************************************
369 -- %* *
370 -- Initialisation: exception handlers
371 -- %* *
372 -- %************************************************************************
373
374
375 -- | Install some default exception handlers and run the inner computation.
376 -- Unless you want to handle exceptions yourself, you should wrap this around
377 -- the top level of your program. The default handlers output the error
378 -- message(s) to stderr and exit cleanly.
379 defaultErrorHandler :: (ExceptionMonad m)
380 => FatalMessager -> FlushOut -> m a -> m a
381 defaultErrorHandler fm (FlushOut flushOut) inner =
382 -- top-level exception handler: any unrecognised exception is a compiler bug.
383 ghandle (\exception -> liftIO $ do
384 flushOut
385 case fromException exception of
386 -- an IO exception probably isn't our fault, so don't panic
387 Just (ioe :: IOException) ->
388 fatalErrorMsg'' fm (show ioe)
389 _ -> case fromException exception of
390 Just UserInterrupt ->
391 -- Important to let this one propagate out so our
392 -- calling process knows we were interrupted by ^C
393 liftIO $ throwIO UserInterrupt
394 Just StackOverflow ->
395 fatalErrorMsg'' fm "stack overflow: use +RTS -K<size> to increase it"
396 _ -> case fromException exception of
397 Just (ex :: ExitCode) -> liftIO $ throwIO ex
398 _ ->
399 fatalErrorMsg'' fm
400 (show (Panic (show exception)))
401 exitWith (ExitFailure 1)
402 ) $
403
404 -- error messages propagated as exceptions
405 handleGhcException
406 (\ge -> liftIO $ do
407 flushOut
408 case ge of
409 Signal _ -> exitWith (ExitFailure 1)
410 _ -> do fatalErrorMsg'' fm (show ge)
411 exitWith (ExitFailure 1)
412 ) $
413 inner
414
415 -- | This function is no longer necessary, cleanup is now done by
416 -- runGhc/runGhcT.
417 {-# DEPRECATED defaultCleanupHandler "Cleanup is now done by runGhc/runGhcT" #-}
418 defaultCleanupHandler :: (ExceptionMonad m) => DynFlags -> m a -> m a
419 defaultCleanupHandler _ m = m
420 where _warning_suppression = m `gonException` undefined
421
422
423 -- %************************************************************************
424 -- %* *
425 -- The Ghc Monad
426 -- %* *
427 -- %************************************************************************
428
429 -- | Run function for the 'Ghc' monad.
430 --
431 -- It initialises the GHC session and warnings via 'initGhcMonad'. Each call
432 -- to this function will create a new session which should not be shared among
433 -- several threads.
434 --
435 -- Any errors not handled inside the 'Ghc' action are propagated as IO
436 -- exceptions.
437
438 runGhc :: Maybe FilePath -- ^ See argument to 'initGhcMonad'.
439 -> Ghc a -- ^ The action to perform.
440 -> IO a
441 runGhc mb_top_dir ghc = do
442 ref <- newIORef (panic "empty session")
443 let session = Session ref
444 flip unGhc session $ withSignalHandlers $ do -- catch ^C
445 initGhcMonad mb_top_dir
446 withCleanupSession ghc
447
448 -- | Run function for 'GhcT' monad transformer.
449 --
450 -- It initialises the GHC session and warnings via 'initGhcMonad'. Each call
451 -- to this function will create a new session which should not be shared among
452 -- several threads.
453
454 runGhcT :: ExceptionMonad m =>
455 Maybe FilePath -- ^ See argument to 'initGhcMonad'.
456 -> GhcT m a -- ^ The action to perform.
457 -> m a
458 runGhcT mb_top_dir ghct = do
459 ref <- liftIO $ newIORef (panic "empty session")
460 let session = Session ref
461 flip unGhcT session $ withSignalHandlers $ do -- catch ^C
462 initGhcMonad mb_top_dir
463 withCleanupSession ghct
464
465 withCleanupSession :: GhcMonad m => m a -> m a
466 withCleanupSession ghc = ghc `gfinally` cleanup
467 where
468 cleanup = do
469 hsc_env <- getSession
470 let dflags = hsc_dflags hsc_env
471 liftIO $ do
472 cleanTempFiles dflags
473 cleanTempDirs dflags
474 stopIServ hsc_env -- shut down the IServ
475 log_finaliser dflags dflags
476 -- exceptions will be blocked while we clean the temporary files,
477 -- so there shouldn't be any difficulty if we receive further
478 -- signals.
479
480 -- | Initialise a GHC session.
481 --
482 -- If you implement a custom 'GhcMonad' you must call this function in the
483 -- monad run function. It will initialise the session variable and clear all
484 -- warnings.
485 --
486 -- The first argument should point to the directory where GHC's library files
487 -- reside. More precisely, this should be the output of @ghc --print-libdir@
488 -- of the version of GHC the module using this API is compiled with. For
489 -- portability, you should use the @ghc-paths@ package, available at
490 -- <http://hackage.haskell.org/package/ghc-paths>.
491
492 initGhcMonad :: GhcMonad m => Maybe FilePath -> m ()
493 initGhcMonad mb_top_dir
494 = do { env <- liftIO $
495 do { mySettings <- initSysTools mb_top_dir
496 ; myLlvmTargets <- initLlvmTargets mb_top_dir
497 ; dflags <- initDynFlags (defaultDynFlags mySettings myLlvmTargets)
498 ; checkBrokenTablesNextToCode dflags
499 ; setUnsafeGlobalDynFlags dflags
500 -- c.f. DynFlags.parseDynamicFlagsFull, which
501 -- creates DynFlags and sets the UnsafeGlobalDynFlags
502 ; newHscEnv dflags }
503 ; setSession env }
504
505 -- | The binutils linker on ARM emits unnecessary R_ARM_COPY relocations which
506 -- breaks tables-next-to-code in dynamically linked modules. This
507 -- check should be more selective but there is currently no released
508 -- version where this bug is fixed.
509 -- See https://sourceware.org/bugzilla/show_bug.cgi?id=16177 and
510 -- https://ghc.haskell.org/trac/ghc/ticket/4210#comment:29
511 checkBrokenTablesNextToCode :: MonadIO m => DynFlags -> m ()
512 checkBrokenTablesNextToCode dflags
513 = do { broken <- checkBrokenTablesNextToCode' dflags
514 ; when broken
515 $ do { _ <- liftIO $ throwIO $ mkApiErr dflags invalidLdErr
516 ; fail "unsupported linker"
517 }
518 }
519 where
520 invalidLdErr = text "Tables-next-to-code not supported on ARM" <+>
521 text "when using binutils ld (please see:" <+>
522 text "https://sourceware.org/bugzilla/show_bug.cgi?id=16177)"
523
524 checkBrokenTablesNextToCode' :: MonadIO m => DynFlags -> m Bool
525 checkBrokenTablesNextToCode' dflags
526 | not (isARM arch) = return False
527 | WayDyn `notElem` ways dflags = return False
528 | not (tablesNextToCode dflags) = return False
529 | otherwise = do
530 linkerInfo <- liftIO $ getLinkerInfo dflags
531 case linkerInfo of
532 GnuLD _ -> return True
533 _ -> return False
534 where platform = targetPlatform dflags
535 arch = platformArch platform
536
537
538 -- %************************************************************************
539 -- %* *
540 -- Flags & settings
541 -- %* *
542 -- %************************************************************************
543
544 -- $DynFlags
545 --
546 -- The GHC session maintains two sets of 'DynFlags':
547 --
548 -- * The "interactive" @DynFlags@, which are used for everything
549 -- related to interactive evaluation, including 'runStmt',
550 -- 'runDecls', 'exprType', 'lookupName' and so on (everything
551 -- under \"Interactive evaluation\" in this module).
552 --
553 -- * The "program" @DynFlags@, which are used when loading
554 -- whole modules with 'load'
555 --
556 -- 'setInteractiveDynFlags', 'getInteractiveDynFlags' work with the
557 -- interactive @DynFlags@.
558 --
559 -- 'setProgramDynFlags', 'getProgramDynFlags' work with the
560 -- program @DynFlags@.
561 --
562 -- 'setSessionDynFlags' sets both @DynFlags@, and 'getSessionDynFlags'
563 -- retrieves the program @DynFlags@ (for backwards compatibility).
564
565
566 -- | Updates both the interactive and program DynFlags in a Session.
567 -- This also reads the package database (unless it has already been
568 -- read), and prepares the compilers knowledge about packages. It can
569 -- be called again to load new packages: just add new package flags to
570 -- (packageFlags dflags).
571 --
572 -- Returns a list of new packages that may need to be linked in using
573 -- the dynamic linker (see 'linkPackages') as a result of new package
574 -- flags. If you are not doing linking or doing static linking, you
575 -- can ignore the list of packages returned.
576 --
577 setSessionDynFlags :: GhcMonad m => DynFlags -> m [InstalledUnitId]
578 setSessionDynFlags dflags = do
579 dflags' <- checkNewDynFlags dflags
580 (dflags'', preload) <- liftIO $ initPackages dflags'
581 modifySession $ \h -> h{ hsc_dflags = dflags''
582 , hsc_IC = (hsc_IC h){ ic_dflags = dflags'' } }
583 invalidateModSummaryCache
584 return preload
585
586 -- | Sets the program 'DynFlags'. Note: this invalidates the internal
587 -- cached module graph, causing more work to be done the next time
588 -- 'load' is called.
589 setProgramDynFlags :: GhcMonad m => DynFlags -> m [InstalledUnitId]
590 setProgramDynFlags dflags = setProgramDynFlags_ True dflags
591
592 -- | Set the action taken when the compiler produces a message. This
593 -- can also be accomplished using 'setProgramDynFlags', but using
594 -- 'setLogAction' avoids invalidating the cached module graph.
595 setLogAction :: GhcMonad m => LogAction -> LogFinaliser -> m ()
596 setLogAction action finaliser = do
597 dflags' <- getProgramDynFlags
598 void $ setProgramDynFlags_ False $
599 dflags' { log_action = action
600 , log_finaliser = finaliser }
601
602 setProgramDynFlags_ :: GhcMonad m => Bool -> DynFlags -> m [InstalledUnitId]
603 setProgramDynFlags_ invalidate_needed dflags = do
604 dflags' <- checkNewDynFlags dflags
605 dflags_prev <- getProgramDynFlags
606 (dflags'', preload) <-
607 if (packageFlagsChanged dflags_prev dflags')
608 then liftIO $ initPackages dflags'
609 else return (dflags', [])
610 modifySession $ \h -> h{ hsc_dflags = dflags'' }
611 when invalidate_needed $ invalidateModSummaryCache
612 return preload
613
614
615 -- When changing the DynFlags, we want the changes to apply to future
616 -- loads, but without completely discarding the program. But the
617 -- DynFlags are cached in each ModSummary in the hsc_mod_graph, so
618 -- after a change to DynFlags, the changes would apply to new modules
619 -- but not existing modules; this seems undesirable.
620 --
621 -- Furthermore, the GHC API client might expect that changing
622 -- log_action would affect future compilation messages, but for those
623 -- modules we have cached ModSummaries for, we'll continue to use the
624 -- old log_action. This is definitely wrong (#7478).
625 --
626 -- Hence, we invalidate the ModSummary cache after changing the
627 -- DynFlags. We do this by tweaking the date on each ModSummary, so
628 -- that the next downsweep will think that all the files have changed
629 -- and preprocess them again. This won't necessarily cause everything
630 -- to be recompiled, because by the time we check whether we need to
631 -- recopmile a module, we'll have re-summarised the module and have a
632 -- correct ModSummary.
633 --
634 invalidateModSummaryCache :: GhcMonad m => m ()
635 invalidateModSummaryCache =
636 modifySession $ \h -> h { hsc_mod_graph = mapMG inval (hsc_mod_graph h) }
637 where
638 inval ms = ms { ms_hs_date = addUTCTime (-1) (ms_hs_date ms) }
639
640 -- | Returns the program 'DynFlags'.
641 getProgramDynFlags :: GhcMonad m => m DynFlags
642 getProgramDynFlags = getSessionDynFlags
643
644 -- | Set the 'DynFlags' used to evaluate interactive expressions.
645 -- Note: this cannot be used for changes to packages. Use
646 -- 'setSessionDynFlags', or 'setProgramDynFlags' and then copy the
647 -- 'pkgState' into the interactive @DynFlags@.
648 setInteractiveDynFlags :: GhcMonad m => DynFlags -> m ()
649 setInteractiveDynFlags dflags = do
650 dflags' <- checkNewDynFlags dflags
651 dflags'' <- checkNewInteractiveDynFlags dflags'
652 modifySession $ \h -> h{ hsc_IC = (hsc_IC h) { ic_dflags = dflags'' }}
653
654 -- | Get the 'DynFlags' used to evaluate interactive expressions.
655 getInteractiveDynFlags :: GhcMonad m => m DynFlags
656 getInteractiveDynFlags = withSession $ \h -> return (ic_dflags (hsc_IC h))
657
658
659 parseDynamicFlags :: MonadIO m =>
660 DynFlags -> [Located String]
661 -> m (DynFlags, [Located String], [Warn])
662 parseDynamicFlags = parseDynamicFlagsCmdLine
663
664 -- | Checks the set of new DynFlags for possibly erroneous option
665 -- combinations when invoking 'setSessionDynFlags' and friends, and if
666 -- found, returns a fixed copy (if possible).
667 checkNewDynFlags :: MonadIO m => DynFlags -> m DynFlags
668 checkNewDynFlags dflags = do
669 -- See Note [DynFlags consistency]
670 let (dflags', warnings) = makeDynFlagsConsistent dflags
671 liftIO $ handleFlagWarnings dflags (map (Warn NoReason) warnings)
672 return dflags'
673
674 checkNewInteractiveDynFlags :: MonadIO m => DynFlags -> m DynFlags
675 checkNewInteractiveDynFlags dflags0 = do
676 dflags1 <-
677 if xopt LangExt.StaticPointers dflags0
678 then do liftIO $ printOrThrowWarnings dflags0 $ listToBag
679 [mkPlainWarnMsg dflags0 interactiveSrcSpan
680 $ text "StaticPointers is not supported in GHCi interactive expressions."]
681 return $ xopt_unset dflags0 LangExt.StaticPointers
682 else return dflags0
683 return dflags1
684
685
686 -- %************************************************************************
687 -- %* *
688 -- Setting, getting, and modifying the targets
689 -- %* *
690 -- %************************************************************************
691
692 -- ToDo: think about relative vs. absolute file paths. And what
693 -- happens when the current directory changes.
694
695 -- | Sets the targets for this session. Each target may be a module name
696 -- or a filename. The targets correspond to the set of root modules for
697 -- the program\/library. Unloading the current program is achieved by
698 -- setting the current set of targets to be empty, followed by 'load'.
699 setTargets :: GhcMonad m => [Target] -> m ()
700 setTargets targets = modifySession (\h -> h{ hsc_targets = targets })
701
702 -- | Returns the current set of targets
703 getTargets :: GhcMonad m => m [Target]
704 getTargets = withSession (return . hsc_targets)
705
706 -- | Add another target.
707 addTarget :: GhcMonad m => Target -> m ()
708 addTarget target
709 = modifySession (\h -> h{ hsc_targets = target : hsc_targets h })
710
711 -- | Remove a target
712 removeTarget :: GhcMonad m => TargetId -> m ()
713 removeTarget target_id
714 = modifySession (\h -> h{ hsc_targets = filter (hsc_targets h) })
715 where
716 filter targets = [ t | t@(Target id _ _) <- targets, id /= target_id ]
717
718 -- | Attempts to guess what Target a string refers to. This function
719 -- implements the @--make@/GHCi command-line syntax for filenames:
720 --
721 -- - if the string looks like a Haskell source filename, then interpret it
722 -- as such
723 --
724 -- - if adding a .hs or .lhs suffix yields the name of an existing file,
725 -- then use that
726 --
727 -- - otherwise interpret the string as a module name
728 --
729 guessTarget :: GhcMonad m => String -> Maybe Phase -> m Target
730 guessTarget str (Just phase)
731 = return (Target (TargetFile str (Just phase)) True Nothing)
732 guessTarget str Nothing
733 | isHaskellSrcFilename file
734 = return (target (TargetFile file Nothing))
735 | otherwise
736 = do exists <- liftIO $ doesFileExist hs_file
737 if exists
738 then return (target (TargetFile hs_file Nothing))
739 else do
740 exists <- liftIO $ doesFileExist lhs_file
741 if exists
742 then return (target (TargetFile lhs_file Nothing))
743 else do
744 if looksLikeModuleName file
745 then return (target (TargetModule (mkModuleName file)))
746 else do
747 dflags <- getDynFlags
748 liftIO $ throwGhcExceptionIO
749 (ProgramError (showSDoc dflags $
750 text "target" <+> quotes (text file) <+>
751 text "is not a module name or a source file"))
752 where
753 (file,obj_allowed)
754 | '*':rest <- str = (rest, False)
755 | otherwise = (str, True)
756
757 hs_file = file <.> "hs"
758 lhs_file = file <.> "lhs"
759
760 target tid = Target tid obj_allowed Nothing
761
762
763 -- | Inform GHC that the working directory has changed. GHC will flush
764 -- its cache of module locations, since it may no longer be valid.
765 --
766 -- Note: Before changing the working directory make sure all threads running
767 -- in the same session have stopped. If you change the working directory,
768 -- you should also unload the current program (set targets to empty,
769 -- followed by load).
770 workingDirectoryChanged :: GhcMonad m => m ()
771 workingDirectoryChanged = withSession $ (liftIO . flushFinderCaches)
772
773
774 -- %************************************************************************
775 -- %* *
776 -- Running phases one at a time
777 -- %* *
778 -- %************************************************************************
779
780 class ParsedMod m where
781 modSummary :: m -> ModSummary
782 parsedSource :: m -> ParsedSource
783
784 class ParsedMod m => TypecheckedMod m where
785 renamedSource :: m -> Maybe RenamedSource
786 typecheckedSource :: m -> TypecheckedSource
787 moduleInfo :: m -> ModuleInfo
788 tm_internals :: m -> (TcGblEnv, ModDetails)
789 -- ToDo: improvements that could be made here:
790 -- if the module succeeded renaming but not typechecking,
791 -- we can still get back the GlobalRdrEnv and exports, so
792 -- perhaps the ModuleInfo should be split up into separate
793 -- fields.
794
795 class TypecheckedMod m => DesugaredMod m where
796 coreModule :: m -> ModGuts
797
798 -- | The result of successful parsing.
799 data ParsedModule =
800 ParsedModule { pm_mod_summary :: ModSummary
801 , pm_parsed_source :: ParsedSource
802 , pm_extra_src_files :: [FilePath]
803 , pm_annotations :: ApiAnns }
804 -- See Note [Api annotations] in ApiAnnotation.hs
805
806 instance ParsedMod ParsedModule where
807 modSummary m = pm_mod_summary m
808 parsedSource m = pm_parsed_source m
809
810 -- | The result of successful typechecking. It also contains the parser
811 -- result.
812 data TypecheckedModule =
813 TypecheckedModule { tm_parsed_module :: ParsedModule
814 , tm_renamed_source :: Maybe RenamedSource
815 , tm_typechecked_source :: TypecheckedSource
816 , tm_checked_module_info :: ModuleInfo
817 , tm_internals_ :: (TcGblEnv, ModDetails)
818 }
819
820 instance ParsedMod TypecheckedModule where
821 modSummary m = modSummary (tm_parsed_module m)
822 parsedSource m = parsedSource (tm_parsed_module m)
823
824 instance TypecheckedMod TypecheckedModule where
825 renamedSource m = tm_renamed_source m
826 typecheckedSource m = tm_typechecked_source m
827 moduleInfo m = tm_checked_module_info m
828 tm_internals m = tm_internals_ m
829
830 -- | The result of successful desugaring (i.e., translation to core). Also
831 -- contains all the information of a typechecked module.
832 data DesugaredModule =
833 DesugaredModule { dm_typechecked_module :: TypecheckedModule
834 , dm_core_module :: ModGuts
835 }
836
837 instance ParsedMod DesugaredModule where
838 modSummary m = modSummary (dm_typechecked_module m)
839 parsedSource m = parsedSource (dm_typechecked_module m)
840
841 instance TypecheckedMod DesugaredModule where
842 renamedSource m = renamedSource (dm_typechecked_module m)
843 typecheckedSource m = typecheckedSource (dm_typechecked_module m)
844 moduleInfo m = moduleInfo (dm_typechecked_module m)
845 tm_internals m = tm_internals_ (dm_typechecked_module m)
846
847 instance DesugaredMod DesugaredModule where
848 coreModule m = dm_core_module m
849
850 type ParsedSource = Located (HsModule GhcPs)
851 type RenamedSource = (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [(LIE GhcRn, Avails)],
852 Maybe LHsDocString)
853 type TypecheckedSource = LHsBinds GhcTc
854
855 -- NOTE:
856 -- - things that aren't in the output of the typechecker right now:
857 -- - the export list
858 -- - the imports
859 -- - type signatures
860 -- - type/data/newtype declarations
861 -- - class declarations
862 -- - instances
863 -- - extra things in the typechecker's output:
864 -- - default methods are turned into top-level decls.
865 -- - dictionary bindings
866
867 -- | Return the 'ModSummary' of a module with the given name.
868 --
869 -- The module must be part of the module graph (see 'hsc_mod_graph' and
870 -- 'ModuleGraph'). If this is not the case, this function will throw a
871 -- 'GhcApiError'.
872 --
873 -- This function ignores boot modules and requires that there is only one
874 -- non-boot module with the given name.
875 getModSummary :: GhcMonad m => ModuleName -> m ModSummary
876 getModSummary mod = do
877 mg <- liftM hsc_mod_graph getSession
878 let mods_by_name = [ ms | ms <- mgModSummaries mg
879 , ms_mod_name ms == mod
880 , not (isBootSummary ms) ]
881 case mods_by_name of
882 [] -> do dflags <- getDynFlags
883 liftIO $ throwIO $ mkApiErr dflags (text "Module not part of module graph")
884 [ms] -> return ms
885 multiple -> do dflags <- getDynFlags
886 liftIO $ throwIO $ mkApiErr dflags (text "getModSummary is ambiguous: " <+> ppr multiple)
887
888 -- | Parse a module.
889 --
890 -- Throws a 'SourceError' on parse error.
891 parseModule :: GhcMonad m => ModSummary -> m ParsedModule
892 parseModule ms = do
893 hsc_env <- getSession
894 let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }
895 hpm <- liftIO $ hscParse hsc_env_tmp ms
896 return (ParsedModule ms (hpm_module hpm) (hpm_src_files hpm)
897 (hpm_annotations hpm))
898 -- See Note [Api annotations] in ApiAnnotation.hs
899
900 -- | Typecheck and rename a parsed module.
901 --
902 -- Throws a 'SourceError' if either fails.
903 typecheckModule :: GhcMonad m => ParsedModule -> m TypecheckedModule
904 typecheckModule pmod = do
905 let ms = modSummary pmod
906 hsc_env <- getSession
907 let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }
908 (tc_gbl_env, rn_info)
909 <- liftIO $ hscTypecheckRename hsc_env_tmp ms $
910 HsParsedModule { hpm_module = parsedSource pmod,
911 hpm_src_files = pm_extra_src_files pmod,
912 hpm_annotations = pm_annotations pmod }
913 details <- liftIO $ makeSimpleDetails hsc_env_tmp tc_gbl_env
914 safe <- liftIO $ finalSafeMode (ms_hspp_opts ms) tc_gbl_env
915
916 return $
917 TypecheckedModule {
918 tm_internals_ = (tc_gbl_env, details),
919 tm_parsed_module = pmod,
920 tm_renamed_source = rn_info,
921 tm_typechecked_source = tcg_binds tc_gbl_env,
922 tm_checked_module_info =
923 ModuleInfo {
924 minf_type_env = md_types details,
925 minf_exports = md_exports details,
926 minf_rdr_env = Just (tcg_rdr_env tc_gbl_env),
927 minf_instances = fixSafeInstances safe $ md_insts details,
928 minf_iface = Nothing,
929 minf_safe = safe,
930 minf_modBreaks = emptyModBreaks
931 }}
932
933 -- | Desugar a typechecked module.
934 desugarModule :: GhcMonad m => TypecheckedModule -> m DesugaredModule
935 desugarModule tcm = do
936 let ms = modSummary tcm
937 let (tcg, _) = tm_internals tcm
938 hsc_env <- getSession
939 let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }
940 guts <- liftIO $ hscDesugar hsc_env_tmp ms tcg
941 return $
942 DesugaredModule {
943 dm_typechecked_module = tcm,
944 dm_core_module = guts
945 }
946
947 -- | Load a module. Input doesn't need to be desugared.
948 --
949 -- A module must be loaded before dependent modules can be typechecked. This
950 -- always includes generating a 'ModIface' and, depending on the
951 -- 'DynFlags.hscTarget', may also include code generation.
952 --
953 -- This function will always cause recompilation and will always overwrite
954 -- previous compilation results (potentially files on disk).
955 --
956 loadModule :: (TypecheckedMod mod, GhcMonad m) => mod -> m mod
957 loadModule tcm = do
958 let ms = modSummary tcm
959 let mod = ms_mod_name ms
960 let loc = ms_location ms
961 let (tcg, _details) = tm_internals tcm
962
963 mb_linkable <- case ms_obj_date ms of
964 Just t | t > ms_hs_date ms -> do
965 l <- liftIO $ findObjectLinkable (ms_mod ms)
966 (ml_obj_file loc) t
967 return (Just l)
968 _otherwise -> return Nothing
969
970 let source_modified | isNothing mb_linkable = SourceModified
971 | otherwise = SourceUnmodified
972 -- we can't determine stability here
973
974 -- compile doesn't change the session
975 hsc_env <- getSession
976 mod_info <- liftIO $ compileOne' (Just tcg) Nothing
977 hsc_env ms 1 1 Nothing mb_linkable
978 source_modified
979
980 modifySession $ \e -> e{ hsc_HPT = addToHpt (hsc_HPT e) mod mod_info }
981 return tcm
982
983
984 -- %************************************************************************
985 -- %* *
986 -- Dealing with Core
987 -- %* *
988 -- %************************************************************************
989
990 -- | A CoreModule consists of just the fields of a 'ModGuts' that are needed for
991 -- the 'GHC.compileToCoreModule' interface.
992 data CoreModule
993 = CoreModule {
994 -- | Module name
995 cm_module :: !Module,
996 -- | Type environment for types declared in this module
997 cm_types :: !TypeEnv,
998 -- | Declarations
999 cm_binds :: CoreProgram,
1000 -- | Safe Haskell mode
1001 cm_safe :: SafeHaskellMode
1002 }
1003
1004 instance Outputable CoreModule where
1005 ppr (CoreModule {cm_module = mn, cm_types = te, cm_binds = cb,
1006 cm_safe = sf})
1007 = text "%module" <+> ppr mn <+> parens (ppr sf) <+> ppr te
1008 $$ vcat (map ppr cb)
1009
1010 -- | This is the way to get access to the Core bindings corresponding
1011 -- to a module. 'compileToCore' parses, typechecks, and
1012 -- desugars the module, then returns the resulting Core module (consisting of
1013 -- the module name, type declarations, and function declarations) if
1014 -- successful.
1015 compileToCoreModule :: GhcMonad m => FilePath -> m CoreModule
1016 compileToCoreModule = compileCore False
1017
1018 -- | Like compileToCoreModule, but invokes the simplifier, so
1019 -- as to return simplified and tidied Core.
1020 compileToCoreSimplified :: GhcMonad m => FilePath -> m CoreModule
1021 compileToCoreSimplified = compileCore True
1022
1023 compileCore :: GhcMonad m => Bool -> FilePath -> m CoreModule
1024 compileCore simplify fn = do
1025 -- First, set the target to the desired filename
1026 target <- guessTarget fn Nothing
1027 addTarget target
1028 _ <- load LoadAllTargets
1029 -- Then find dependencies
1030 modGraph <- depanal [] True
1031 case find ((== fn) . msHsFilePath) (mgModSummaries modGraph) of
1032 Just modSummary -> do
1033 -- Now we have the module name;
1034 -- parse, typecheck and desugar the module
1035 (tcg, mod_guts) <- -- TODO: space leaky: call hsc* directly?
1036 do tm <- typecheckModule =<< parseModule modSummary
1037 let tcg = fst (tm_internals tm)
1038 (,) tcg . coreModule <$> desugarModule tm
1039 liftM (gutsToCoreModule (mg_safe_haskell mod_guts)) $
1040 if simplify
1041 then do
1042 -- If simplify is true: simplify (hscSimplify), then tidy
1043 -- (tidyProgram).
1044 hsc_env <- getSession
1045 simpl_guts <- liftIO $ do
1046 plugins <- readIORef (tcg_th_coreplugins tcg)
1047 hscSimplify hsc_env plugins mod_guts
1048 tidy_guts <- liftIO $ tidyProgram hsc_env simpl_guts
1049 return $ Left tidy_guts
1050 else
1051 return $ Right mod_guts
1052
1053 Nothing -> panic "compileToCoreModule: target FilePath not found in\
1054 module dependency graph"
1055 where -- two versions, based on whether we simplify (thus run tidyProgram,
1056 -- which returns a (CgGuts, ModDetails) pair, or not (in which case
1057 -- we just have a ModGuts.
1058 gutsToCoreModule :: SafeHaskellMode
1059 -> Either (CgGuts, ModDetails) ModGuts
1060 -> CoreModule
1061 gutsToCoreModule safe_mode (Left (cg, md)) = CoreModule {
1062 cm_module = cg_module cg,
1063 cm_types = md_types md,
1064 cm_binds = cg_binds cg,
1065 cm_safe = safe_mode
1066 }
1067 gutsToCoreModule safe_mode (Right mg) = CoreModule {
1068 cm_module = mg_module mg,
1069 cm_types = typeEnvFromEntities (bindersOfBinds (mg_binds mg))
1070 (mg_tcs mg)
1071 (mg_fam_insts mg),
1072 cm_binds = mg_binds mg,
1073 cm_safe = safe_mode
1074 }
1075
1076 -- %************************************************************************
1077 -- %* *
1078 -- Inspecting the session
1079 -- %* *
1080 -- %************************************************************************
1081
1082 -- | Get the module dependency graph.
1083 getModuleGraph :: GhcMonad m => m ModuleGraph -- ToDo: DiGraph ModSummary
1084 getModuleGraph = liftM hsc_mod_graph getSession
1085
1086 -- | Return @True@ <==> module is loaded.
1087 isLoaded :: GhcMonad m => ModuleName -> m Bool
1088 isLoaded m = withSession $ \hsc_env ->
1089 return $! isJust (lookupHpt (hsc_HPT hsc_env) m)
1090
1091 -- | Return the bindings for the current interactive session.
1092 getBindings :: GhcMonad m => m [TyThing]
1093 getBindings = withSession $ \hsc_env ->
1094 return $ icInScopeTTs $ hsc_IC hsc_env
1095
1096 -- | Return the instances for the current interactive session.
1097 getInsts :: GhcMonad m => m ([ClsInst], [FamInst])
1098 getInsts = withSession $ \hsc_env ->
1099 return $ ic_instances (hsc_IC hsc_env)
1100
1101 getPrintUnqual :: GhcMonad m => m PrintUnqualified
1102 getPrintUnqual = withSession $ \hsc_env ->
1103 return (icPrintUnqual (hsc_dflags hsc_env) (hsc_IC hsc_env))
1104
1105 -- | Container for information about a 'Module'.
1106 data ModuleInfo = ModuleInfo {
1107 minf_type_env :: TypeEnv,
1108 minf_exports :: [AvailInfo],
1109 minf_rdr_env :: Maybe GlobalRdrEnv, -- Nothing for a compiled/package mod
1110 minf_instances :: [ClsInst],
1111 minf_iface :: Maybe ModIface,
1112 minf_safe :: SafeHaskellMode,
1113 minf_modBreaks :: ModBreaks
1114 }
1115 -- We don't want HomeModInfo here, because a ModuleInfo applies
1116 -- to package modules too.
1117
1118 -- | Request information about a loaded 'Module'
1119 getModuleInfo :: GhcMonad m => Module -> m (Maybe ModuleInfo) -- XXX: Maybe X
1120 getModuleInfo mdl = withSession $ \hsc_env -> do
1121 let mg = hsc_mod_graph hsc_env
1122 if mgElemModule mg mdl
1123 then liftIO $ getHomeModuleInfo hsc_env mdl
1124 else do
1125 {- if isHomeModule (hsc_dflags hsc_env) mdl
1126 then return Nothing
1127 else -} liftIO $ getPackageModuleInfo hsc_env mdl
1128 -- ToDo: we don't understand what the following comment means.
1129 -- (SDM, 19/7/2011)
1130 -- getPackageModuleInfo will attempt to find the interface, so
1131 -- we don't want to call it for a home module, just in case there
1132 -- was a problem loading the module and the interface doesn't
1133 -- exist... hence the isHomeModule test here. (ToDo: reinstate)
1134
1135 getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
1136 getPackageModuleInfo hsc_env mdl
1137 = do eps <- hscEPS hsc_env
1138 iface <- hscGetModuleInterface hsc_env mdl
1139 let
1140 avails = mi_exports iface
1141 pte = eps_PTE eps
1142 tys = [ ty | name <- concatMap availNames avails,
1143 Just ty <- [lookupTypeEnv pte name] ]
1144 --
1145 return (Just (ModuleInfo {
1146 minf_type_env = mkTypeEnv tys,
1147 minf_exports = avails,
1148 minf_rdr_env = Just $! availsToGlobalRdrEnv (moduleName mdl) avails,
1149 minf_instances = error "getModuleInfo: instances for package module unimplemented",
1150 minf_iface = Just iface,
1151 minf_safe = getSafeMode $ mi_trust iface,
1152 minf_modBreaks = emptyModBreaks
1153 }))
1154
1155 getHomeModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
1156 getHomeModuleInfo hsc_env mdl =
1157 case lookupHpt (hsc_HPT hsc_env) (moduleName mdl) of
1158 Nothing -> return Nothing
1159 Just hmi -> do
1160 let details = hm_details hmi
1161 iface = hm_iface hmi
1162 return (Just (ModuleInfo {
1163 minf_type_env = md_types details,
1164 minf_exports = md_exports details,
1165 minf_rdr_env = mi_globals $! hm_iface hmi,
1166 minf_instances = md_insts details,
1167 minf_iface = Just iface,
1168 minf_safe = getSafeMode $ mi_trust iface
1169 ,minf_modBreaks = getModBreaks hmi
1170 }))
1171
1172 -- | The list of top-level entities defined in a module
1173 modInfoTyThings :: ModuleInfo -> [TyThing]
1174 modInfoTyThings minf = typeEnvElts (minf_type_env minf)
1175
1176 modInfoTopLevelScope :: ModuleInfo -> Maybe [Name]
1177 modInfoTopLevelScope minf
1178 = fmap (map gre_name . globalRdrEnvElts) (minf_rdr_env minf)
1179
1180 modInfoExports :: ModuleInfo -> [Name]
1181 modInfoExports minf = concatMap availNames $! minf_exports minf
1182
1183 modInfoExportsWithSelectors :: ModuleInfo -> [Name]
1184 modInfoExportsWithSelectors minf = concatMap availNamesWithSelectors $! minf_exports minf
1185
1186 -- | Returns the instances defined by the specified module.
1187 -- Warning: currently unimplemented for package modules.
1188 modInfoInstances :: ModuleInfo -> [ClsInst]
1189 modInfoInstances = minf_instances
1190
1191 modInfoIsExportedName :: ModuleInfo -> Name -> Bool
1192 modInfoIsExportedName minf name = elemNameSet name (availsToNameSet (minf_exports minf))
1193
1194 mkPrintUnqualifiedForModule :: GhcMonad m =>
1195 ModuleInfo
1196 -> m (Maybe PrintUnqualified) -- XXX: returns a Maybe X
1197 mkPrintUnqualifiedForModule minf = withSession $ \hsc_env -> do
1198 return (fmap (mkPrintUnqualified (hsc_dflags hsc_env)) (minf_rdr_env minf))
1199
1200 modInfoLookupName :: GhcMonad m =>
1201 ModuleInfo -> Name
1202 -> m (Maybe TyThing) -- XXX: returns a Maybe X
1203 modInfoLookupName minf name = withSession $ \hsc_env -> do
1204 case lookupTypeEnv (minf_type_env minf) name of
1205 Just tyThing -> return (Just tyThing)
1206 Nothing -> do
1207 eps <- liftIO $ readIORef (hsc_EPS hsc_env)
1208 return $! lookupType (hsc_dflags hsc_env)
1209 (hsc_HPT hsc_env) (eps_PTE eps) name
1210
1211 modInfoIface :: ModuleInfo -> Maybe ModIface
1212 modInfoIface = minf_iface
1213
1214 -- | Retrieve module safe haskell mode
1215 modInfoSafe :: ModuleInfo -> SafeHaskellMode
1216 modInfoSafe = minf_safe
1217
1218 modInfoModBreaks :: ModuleInfo -> ModBreaks
1219 modInfoModBreaks = minf_modBreaks
1220
1221 isDictonaryId :: Id -> Bool
1222 isDictonaryId id
1223 = case tcSplitSigmaTy (idType id) of {
1224 (_tvs, _theta, tau) -> isDictTy tau }
1225
1226 -- | Looks up a global name: that is, any top-level name in any
1227 -- visible module. Unlike 'lookupName', lookupGlobalName does not use
1228 -- the interactive context, and therefore does not require a preceding
1229 -- 'setContext'.
1230 lookupGlobalName :: GhcMonad m => Name -> m (Maybe TyThing)
1231 lookupGlobalName name = withSession $ \hsc_env -> do
1232 liftIO $ lookupTypeHscEnv hsc_env name
1233
1234 findGlobalAnns :: (GhcMonad m, Typeable a) => ([Word8] -> a) -> AnnTarget Name -> m [a]
1235 findGlobalAnns deserialize target = withSession $ \hsc_env -> do
1236 ann_env <- liftIO $ prepareAnnotations hsc_env Nothing
1237 return (findAnns deserialize ann_env target)
1238
1239 -- | get the GlobalRdrEnv for a session
1240 getGRE :: GhcMonad m => m GlobalRdrEnv
1241 getGRE = withSession $ \hsc_env-> return $ ic_rn_gbl_env (hsc_IC hsc_env)
1242
1243 -- | Retrieve all type and family instances in the environment, indexed
1244 -- by 'Name'. Each name's lists will contain every instance in which that name
1245 -- is mentioned in the instance head.
1246 getNameToInstancesIndex :: GhcMonad m
1247 => m (Messages, Maybe (NameEnv ([ClsInst], [FamInst])))
1248 getNameToInstancesIndex = do
1249 hsc_env <- getSession
1250 liftIO $ runTcInteractive hsc_env $
1251 do { loadUnqualIfaces hsc_env (hsc_IC hsc_env)
1252 ; InstEnvs {ie_global, ie_local, ie_visible} <- tcGetInstEnvs
1253 ; (pkg_fie, home_fie) <- tcGetFamInstEnvs
1254 -- We use Data.Sequence.Seq because we are creating left associated
1255 -- mappends.
1256 -- cls_index and fam_index below are adapted from TcRnDriver.lookupInsts
1257 ; let cls_index = Map.fromListWith mappend
1258 [ (n, Seq.singleton ispec)
1259 | ispec <- instEnvElts ie_local ++ instEnvElts ie_global
1260 , instIsVisible ie_visible ispec
1261 , n <- nameSetElemsStable $ orphNamesOfClsInst ispec
1262 ]
1263 ; let fam_index = Map.fromListWith mappend
1264 [ (n, Seq.singleton fispec)
1265 | fispec <- famInstEnvElts home_fie ++ famInstEnvElts pkg_fie
1266 , n <- nameSetElemsStable $ orphNamesOfFamInst fispec
1267 ]
1268 ; return $ mkNameEnv $
1269 [ (nm, (toList clss, toList fams))
1270 | (nm, (clss, fams)) <- Map.toList $ Map.unionWith mappend
1271 (fmap (,Seq.empty) cls_index)
1272 (fmap (Seq.empty,) fam_index)
1273 ] }
1274
1275 -- -----------------------------------------------------------------------------
1276
1277 {- ToDo: Move the primary logic here to compiler/main/Packages.hs
1278 -- | Return all /external/ modules available in the package database.
1279 -- Modules from the current session (i.e., from the 'HomePackageTable') are
1280 -- not included. This includes module names which are reexported by packages.
1281 packageDbModules :: GhcMonad m =>
1282 Bool -- ^ Only consider exposed packages.
1283 -> m [Module]
1284 packageDbModules only_exposed = do
1285 dflags <- getSessionDynFlags
1286 let pkgs = eltsUFM (pkgIdMap (pkgState dflags))
1287 return $
1288 [ mkModule pid modname
1289 | p <- pkgs
1290 , not only_exposed || exposed p
1291 , let pid = packageConfigId p
1292 , modname <- exposedModules p
1293 ++ map exportName (reexportedModules p) ]
1294 -}
1295
1296 -- -----------------------------------------------------------------------------
1297 -- Misc exported utils
1298
1299 dataConType :: DataCon -> Type
1300 dataConType dc = idType (dataConWrapId dc)
1301
1302 -- | print a 'NamedThing', adding parentheses if the name is an operator.
1303 pprParenSymName :: NamedThing a => a -> SDoc
1304 pprParenSymName a = parenSymOcc (getOccName a) (ppr (getName a))
1305
1306 -- ----------------------------------------------------------------------------
1307
1308
1309 -- ToDo:
1310 -- - Data and Typeable instances for HsSyn.
1311
1312 -- ToDo: check for small transformations that happen to the syntax in
1313 -- the typechecker (eg. -e ==> negate e, perhaps for fromIntegral)
1314
1315 -- ToDo: maybe use TH syntax instead of IfaceSyn? There's already a way
1316 -- to get from TyCons, Ids etc. to TH syntax (reify).
1317
1318 -- :browse will use either lm_toplev or inspect lm_interface, depending
1319 -- on whether the module is interpreted or not.
1320
1321
1322 -- Extract the filename, stringbuffer content and dynflags associed to a module
1323 --
1324 -- XXX: Explain pre-conditions
1325 getModuleSourceAndFlags :: GhcMonad m => Module -> m (String, StringBuffer, DynFlags)
1326 getModuleSourceAndFlags mod = do
1327 m <- getModSummary (moduleName mod)
1328 case ml_hs_file $ ms_location m of
1329 Nothing -> do dflags <- getDynFlags
1330 liftIO $ throwIO $ mkApiErr dflags (text "No source available for module " <+> ppr mod)
1331 Just sourceFile -> do
1332 source <- liftIO $ hGetStringBuffer sourceFile
1333 return (sourceFile, source, ms_hspp_opts m)
1334
1335
1336 -- | Return module source as token stream, including comments.
1337 --
1338 -- The module must be in the module graph and its source must be available.
1339 -- Throws a 'HscTypes.SourceError' on parse error.
1340 getTokenStream :: GhcMonad m => Module -> m [Located Token]
1341 getTokenStream mod = do
1342 (sourceFile, source, flags) <- getModuleSourceAndFlags mod
1343 let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1
1344 case lexTokenStream source startLoc flags of
1345 POk _ ts -> return ts
1346 PFailed _ span err ->
1347 do dflags <- getDynFlags
1348 liftIO $ throwIO $ mkSrcErr (unitBag $ mkPlainErrMsg dflags span err)
1349
1350 -- | Give even more information on the source than 'getTokenStream'
1351 -- This function allows reconstructing the source completely with
1352 -- 'showRichTokenStream'.
1353 getRichTokenStream :: GhcMonad m => Module -> m [(Located Token, String)]
1354 getRichTokenStream mod = do
1355 (sourceFile, source, flags) <- getModuleSourceAndFlags mod
1356 let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1
1357 case lexTokenStream source startLoc flags of
1358 POk _ ts -> return $ addSourceToTokens startLoc source ts
1359 PFailed _ span err ->
1360 do dflags <- getDynFlags
1361 liftIO $ throwIO $ mkSrcErr (unitBag $ mkPlainErrMsg dflags span err)
1362
1363 -- | Given a source location and a StringBuffer corresponding to this
1364 -- location, return a rich token stream with the source associated to the
1365 -- tokens.
1366 addSourceToTokens :: RealSrcLoc -> StringBuffer -> [Located Token]
1367 -> [(Located Token, String)]
1368 addSourceToTokens _ _ [] = []
1369 addSourceToTokens loc buf (t@(L span _) : ts)
1370 = case span of
1371 UnhelpfulSpan _ -> (t,"") : addSourceToTokens loc buf ts
1372 RealSrcSpan s -> (t,str) : addSourceToTokens newLoc newBuf ts
1373 where
1374 (newLoc, newBuf, str) = go "" loc buf
1375 start = realSrcSpanStart s
1376 end = realSrcSpanEnd s
1377 go acc loc buf | loc < start = go acc nLoc nBuf
1378 | start <= loc && loc < end = go (ch:acc) nLoc nBuf
1379 | otherwise = (loc, buf, reverse acc)
1380 where (ch, nBuf) = nextChar buf
1381 nLoc = advanceSrcLoc loc ch
1382
1383
1384 -- | Take a rich token stream such as produced from 'getRichTokenStream' and
1385 -- return source code almost identical to the original code (except for
1386 -- insignificant whitespace.)
1387 showRichTokenStream :: [(Located Token, String)] -> String
1388 showRichTokenStream ts = go startLoc ts ""
1389 where sourceFile = getFile $ map (getLoc . fst) ts
1390 getFile [] = panic "showRichTokenStream: No source file found"
1391 getFile (UnhelpfulSpan _ : xs) = getFile xs
1392 getFile (RealSrcSpan s : _) = srcSpanFile s
1393 startLoc = mkRealSrcLoc sourceFile 1 1
1394 go _ [] = id
1395 go loc ((L span _, str):ts)
1396 = case span of
1397 UnhelpfulSpan _ -> go loc ts
1398 RealSrcSpan s
1399 | locLine == tokLine -> ((replicate (tokCol - locCol) ' ') ++)
1400 . (str ++)
1401 . go tokEnd ts
1402 | otherwise -> ((replicate (tokLine - locLine) '\n') ++)
1403 . ((replicate (tokCol - 1) ' ') ++)
1404 . (str ++)
1405 . go tokEnd ts
1406 where (locLine, locCol) = (srcLocLine loc, srcLocCol loc)
1407 (tokLine, tokCol) = (srcSpanStartLine s, srcSpanStartCol s)
1408 tokEnd = realSrcSpanEnd s
1409
1410 -- -----------------------------------------------------------------------------
1411 -- Interactive evaluation
1412
1413 -- | Takes a 'ModuleName' and possibly a 'UnitId', and consults the
1414 -- filesystem and package database to find the corresponding 'Module',
1415 -- using the algorithm that is used for an @import@ declaration.
1416 findModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module
1417 findModule mod_name maybe_pkg = withSession $ \hsc_env -> do
1418 let
1419 dflags = hsc_dflags hsc_env
1420 this_pkg = thisPackage dflags
1421 --
1422 case maybe_pkg of
1423 Just pkg | fsToUnitId pkg /= this_pkg && pkg /= fsLit "this" -> liftIO $ do
1424 res <- findImportedModule hsc_env mod_name maybe_pkg
1425 case res of
1426 Found _ m -> return m
1427 err -> throwOneError $ noModError dflags noSrcSpan mod_name err
1428 _otherwise -> do
1429 home <- lookupLoadedHomeModule mod_name
1430 case home of
1431 Just m -> return m
1432 Nothing -> liftIO $ do
1433 res <- findImportedModule hsc_env mod_name maybe_pkg
1434 case res of
1435 Found loc m | moduleUnitId m /= this_pkg -> return m
1436 | otherwise -> modNotLoadedError dflags m loc
1437 err -> throwOneError $ noModError dflags noSrcSpan mod_name err
1438
1439 modNotLoadedError :: DynFlags -> Module -> ModLocation -> IO a
1440 modNotLoadedError dflags m loc = throwGhcExceptionIO $ CmdLineError $ showSDoc dflags $
1441 text "module is not loaded:" <+>
1442 quotes (ppr (moduleName m)) <+>
1443 parens (text (expectJust "modNotLoadedError" (ml_hs_file loc)))
1444
1445 -- | Like 'findModule', but differs slightly when the module refers to
1446 -- a source file, and the file has not been loaded via 'load'. In
1447 -- this case, 'findModule' will throw an error (module not loaded),
1448 -- but 'lookupModule' will check to see whether the module can also be
1449 -- found in a package, and if so, that package 'Module' will be
1450 -- returned. If not, the usual module-not-found error will be thrown.
1451 --
1452 lookupModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module
1453 lookupModule mod_name (Just pkg) = findModule mod_name (Just pkg)
1454 lookupModule mod_name Nothing = withSession $ \hsc_env -> do
1455 home <- lookupLoadedHomeModule mod_name
1456 case home of
1457 Just m -> return m
1458 Nothing -> liftIO $ do
1459 res <- findExposedPackageModule hsc_env mod_name Nothing
1460 case res of
1461 Found _ m -> return m
1462 err -> throwOneError $ noModError (hsc_dflags hsc_env) noSrcSpan mod_name err
1463
1464 lookupLoadedHomeModule :: GhcMonad m => ModuleName -> m (Maybe Module)
1465 lookupLoadedHomeModule mod_name = withSession $ \hsc_env ->
1466 case lookupHpt (hsc_HPT hsc_env) mod_name of
1467 Just mod_info -> return (Just (mi_module (hm_iface mod_info)))
1468 _not_a_home_module -> return Nothing
1469
1470 -- | Check that a module is safe to import (according to Safe Haskell).
1471 --
1472 -- We return True to indicate the import is safe and False otherwise
1473 -- although in the False case an error may be thrown first.
1474 isModuleTrusted :: GhcMonad m => Module -> m Bool
1475 isModuleTrusted m = withSession $ \hsc_env ->
1476 liftIO $ hscCheckSafe hsc_env m noSrcSpan
1477
1478 -- | Return if a module is trusted and the pkgs it depends on to be trusted.
1479 moduleTrustReqs :: GhcMonad m => Module -> m (Bool, Set InstalledUnitId)
1480 moduleTrustReqs m = withSession $ \hsc_env ->
1481 liftIO $ hscGetSafe hsc_env m noSrcSpan
1482
1483 -- | Set the monad GHCi lifts user statements into.
1484 --
1485 -- Checks that a type (in string form) is an instance of the
1486 -- @GHC.GHCi.GHCiSandboxIO@ type class. Sets it to be the GHCi monad if it is,
1487 -- throws an error otherwise.
1488 setGHCiMonad :: GhcMonad m => String -> m ()
1489 setGHCiMonad name = withSession $ \hsc_env -> do
1490 ty <- liftIO $ hscIsGHCiMonad hsc_env name
1491 modifySession $ \s ->
1492 let ic = (hsc_IC s) { ic_monad = ty }
1493 in s { hsc_IC = ic }
1494
1495 -- | Get the monad GHCi lifts user statements into.
1496 getGHCiMonad :: GhcMonad m => m Name
1497 getGHCiMonad = fmap (ic_monad . hsc_IC) getSession
1498
1499 getHistorySpan :: GhcMonad m => History -> m SrcSpan
1500 getHistorySpan h = withSession $ \hsc_env ->
1501 return $ InteractiveEval.getHistorySpan hsc_env h
1502
1503 obtainTermFromVal :: GhcMonad m => Int -> Bool -> Type -> a -> m Term
1504 obtainTermFromVal bound force ty a = withSession $ \hsc_env ->
1505 liftIO $ InteractiveEval.obtainTermFromVal hsc_env bound force ty a
1506
1507 obtainTermFromId :: GhcMonad m => Int -> Bool -> Id -> m Term
1508 obtainTermFromId bound force id = withSession $ \hsc_env ->
1509 liftIO $ InteractiveEval.obtainTermFromId hsc_env bound force id
1510
1511
1512 -- | Returns the 'TyThing' for a 'Name'. The 'Name' may refer to any
1513 -- entity known to GHC, including 'Name's defined using 'runStmt'.
1514 lookupName :: GhcMonad m => Name -> m (Maybe TyThing)
1515 lookupName name =
1516 withSession $ \hsc_env ->
1517 liftIO $ hscTcRcLookupName hsc_env name
1518
1519 -- -----------------------------------------------------------------------------
1520 -- Pure API
1521
1522 -- | A pure interface to the module parser.
1523 --
1524 parser :: String -- ^ Haskell module source text (full Unicode is supported)
1525 -> DynFlags -- ^ the flags
1526 -> FilePath -- ^ the filename (for source locations)
1527 -> (WarningMessages, Either ErrorMessages (Located (HsModule GhcPs)))
1528
1529 parser str dflags filename =
1530 let
1531 loc = mkRealSrcLoc (mkFastString filename) 1 1
1532 buf = stringToStringBuffer str
1533 in
1534 case unP Parser.parseModule (mkPState dflags buf loc) of
1535
1536 PFailed warnFn span err ->
1537 let (warns,_) = warnFn dflags in
1538 (warns, Left $ unitBag (mkPlainErrMsg dflags span err))
1539
1540 POk pst rdr_module ->
1541 let (warns,_) = getMessages pst dflags in
1542 (warns, Right rdr_module)