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