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