never executed always true always false
1 {-# LANGUAGE CPP #-}
2 {-# LANGUAGE NondecreasingIndentation, ScopedTypeVariables #-}
3 {-# LANGUAGE TupleSections, NamedFieldPuns #-}
4 {-# LANGUAGE ViewPatterns #-}
5 {-# LANGUAGE TypeFamilies #-}
6
7 -- -----------------------------------------------------------------------------
8 --
9 -- (c) The University of Glasgow, 2005-2012
10 --
11 -- The GHC API
12 --
13 -- -----------------------------------------------------------------------------
14
15 module GHC (
16 -- * Initialisation
17 defaultErrorHandler,
18 defaultCleanupHandler,
19 prettyPrintGhcErrors,
20 withSignalHandlers,
21 withCleanupSession,
22
23 -- * GHC Monad
24 Ghc, GhcT, GhcMonad(..), HscEnv,
25 runGhc, runGhcT, initGhcMonad,
26 printException,
27 handleSourceError,
28 needsTemplateHaskellOrQQ,
29
30 -- * Flags and settings
31 DynFlags(..), GeneralFlag(..), Severity(..), Backend(..), gopt,
32 GhcMode(..), GhcLink(..),
33 parseDynamicFlags, parseTargetFiles,
34 getSessionDynFlags, setSessionDynFlags,
35 getProgramDynFlags, setProgramDynFlags,
36 getInteractiveDynFlags, setInteractiveDynFlags,
37 interpretPackageEnv,
38
39 -- * Logging
40 Logger, getLogger,
41 pushLogHook, popLogHook,
42 pushLogHookM, popLogHookM, modifyLogger,
43 putMsgM, putLogMsgM,
44
45
46 -- * Targets
47 Target(..), TargetId(..), Phase,
48 setTargets,
49 getTargets,
50 addTarget,
51 removeTarget,
52 guessTarget,
53
54 -- * Loading\/compiling the program
55 depanal, depanalE,
56 load, loadWithCache, LoadHowMuch(..), InteractiveImport(..),
57 SuccessFlag(..), succeeded, failed,
58 defaultWarnErrLogger, WarnErrLogger,
59 workingDirectoryChanged,
60 parseModule, typecheckModule, desugarModule,
61 ParsedModule(..), TypecheckedModule(..), DesugaredModule(..),
62 TypecheckedSource, ParsedSource, RenamedSource, -- ditto
63 TypecheckedMod, ParsedMod,
64 moduleInfo, renamedSource, typecheckedSource,
65 parsedSource, coreModule,
66 PkgQual(..),
67
68 -- ** Compiling to Core
69 CoreModule(..),
70 compileToCoreModule, compileToCoreSimplified,
71
72 -- * Inspecting the module structure of the program
73 ModuleGraph, emptyMG, mapMG, mkModuleGraph, mgModSummaries,
74 mgLookupModule,
75 ModSummary(..), ms_mod_name, ModLocation(..),
76 getModSummary,
77 getModuleGraph,
78 isLoaded,
79 topSortModuleGraph,
80
81 -- * Inspecting modules
82 ModuleInfo,
83 getModuleInfo,
84 modInfoTyThings,
85 modInfoTopLevelScope,
86 modInfoExports,
87 modInfoExportsWithSelectors,
88 modInfoInstances,
89 modInfoIsExportedName,
90 modInfoLookupName,
91 modInfoIface,
92 modInfoRdrEnv,
93 modInfoSafe,
94 lookupGlobalName,
95 findGlobalAnns,
96 mkPrintUnqualifiedForModule,
97 ModIface, ModIface_(..),
98 SafeHaskellMode(..),
99
100 -- * Printing
101 PrintUnqualified, alwaysQualify,
102
103 -- * Interactive evaluation
104
105 -- ** Executing statements
106 execStmt, execStmt', ExecOptions(..), execOptions, ExecResult(..),
107 resumeExec,
108
109 -- ** Adding new declarations
110 runDecls, runDeclsWithLocation, runParsedDecls,
111
112 -- ** Get/set the current context
113 parseImportDecl,
114 setContext, getContext,
115 setGHCiMonad, getGHCiMonad,
116
117 -- ** Inspecting the current context
118 getBindings, getInsts, getPrintUnqual,
119 findModule, lookupModule,
120 findQualifiedModule, lookupQualifiedModule,
121 renamePkgQualM, renameRawPkgQualM,
122 isModuleTrusted, moduleTrustReqs,
123 getNamesInScope,
124 getRdrNamesInScope,
125 getGRE,
126 moduleIsInterpreted,
127 getInfo,
128 showModule,
129 moduleIsBootOrNotObjectLinkable,
130 getNameToInstancesIndex,
131
132 -- ** Inspecting types and kinds
133 exprType, TcRnExprMode(..),
134 typeKind,
135
136 -- ** Looking up a Name
137 parseName,
138 lookupName,
139
140 -- ** Compiling expressions
141 HValue, parseExpr, compileParsedExpr,
142 GHC.Runtime.Eval.compileExpr, dynCompileExpr,
143 ForeignHValue,
144 compileExprRemote, compileParsedExprRemote,
145
146 -- ** Docs
147 getDocs, GetDocsFailure(..),
148
149 -- ** Other
150 runTcInteractive, -- Desired by some clients (#8878)
151 isStmt, hasImport, isImport, isDecl,
152
153 -- ** The debugger
154 SingleStep(..),
155 Resume(..),
156 History(historyBreakInfo, historyEnclosingDecls),
157 GHC.getHistorySpan, getHistoryModule,
158 abandon, abandonAll,
159 getResumeContext,
160 GHC.obtainTermFromId, GHC.obtainTermFromVal, reconstructType,
161 modInfoModBreaks,
162 ModBreaks(..), BreakIndex,
163 BreakInfo(..),
164 GHC.Runtime.Eval.back,
165 GHC.Runtime.Eval.forward,
166 GHC.Runtime.Eval.setupBreakpoint,
167
168 -- * Abstract syntax elements
169
170 -- ** Units
171 Unit,
172
173 -- ** Modules
174 Module, mkModule, pprModule, moduleName, moduleUnit,
175 ModuleName, mkModuleName, moduleNameString,
176
177 -- ** Names
178 Name,
179 isExternalName, nameModule, pprParenSymName, nameSrcSpan,
180 NamedThing(..),
181 RdrName(Qual,Unqual),
182
183 -- ** Identifiers
184 Id, idType,
185 isImplicitId, isDeadBinder,
186 isExportedId, isLocalId, isGlobalId,
187 isRecordSelector,
188 isPrimOpId, isFCallId, isClassOpId_maybe,
189 isDataConWorkId, idDataCon,
190 isDeadEndId, isDictonaryId,
191 recordSelectorTyCon,
192
193 -- ** Type constructors
194 TyCon,
195 tyConTyVars, tyConDataCons, tyConArity,
196 isClassTyCon, isTypeSynonymTyCon, isTypeFamilyTyCon, isNewTyCon,
197 isPrimTyCon, isFunTyCon,
198 isFamilyTyCon, isOpenFamilyTyCon, isOpenTypeFamilyTyCon,
199 tyConClass_maybe,
200 synTyConRhs_maybe, synTyConDefn_maybe, tyConKind,
201
202 -- ** Type variables
203 TyVar,
204 alphaTyVars,
205
206 -- ** Data constructors
207 DataCon,
208 dataConType, dataConTyCon, dataConFieldLabels,
209 dataConIsInfix, isVanillaDataCon, dataConWrapperType,
210 dataConSrcBangs,
211 StrictnessMark(..), isMarkedStrict,
212
213 -- ** Classes
214 Class,
215 classMethods, classSCTheta, classTvsFds, classATs,
216 pprFundeps,
217
218 -- ** Instances
219 ClsInst,
220 instanceDFunId,
221 pprInstance, pprInstanceHdr,
222 pprFamInst,
223
224 FamInst,
225
226 -- ** Types and Kinds
227 Type, splitForAllTyCoVars, funResultTy,
228 pprParendType, pprTypeApp,
229 Kind,
230 PredType,
231 ThetaType, pprForAll, pprThetaArrowTy,
232 parseInstanceHead,
233 getInstancesForType,
234
235 -- ** Entities
236 TyThing(..),
237
238 -- ** Syntax
239 module GHC.Hs, -- ToDo: remove extraneous bits
240
241 -- ** Fixities
242 FixityDirection(..),
243 defaultFixity, maxPrecedence,
244 negateFixity,
245 compareFixity,
246 LexicalFixity(..),
247
248 -- ** Source locations
249 SrcLoc(..), RealSrcLoc,
250 mkSrcLoc, noSrcLoc,
251 srcLocFile, srcLocLine, srcLocCol,
252 SrcSpan(..), RealSrcSpan,
253 mkSrcSpan, srcLocSpan, isGoodSrcSpan, noSrcSpan,
254 srcSpanStart, srcSpanEnd,
255 srcSpanFile,
256 srcSpanStartLine, srcSpanEndLine,
257 srcSpanStartCol, srcSpanEndCol,
258
259 -- ** Located
260 GenLocated(..), Located, RealLocated,
261
262 -- *** Constructing Located
263 noLoc, mkGeneralLocated,
264
265 -- *** Deconstructing Located
266 getLoc, unLoc,
267 getRealSrcSpan, unRealSrcSpan,
268
269 -- *** Combining and comparing Located values
270 eqLocated, cmpLocated, combineLocs, addCLoc,
271 leftmost_smallest, leftmost_largest, rightmost_smallest,
272 spans, isSubspanOf,
273
274 -- * Exceptions
275 GhcException(..), showGhcException,
276 GhcApiError(..),
277
278 -- * Token stream manipulations
279 Token,
280 getTokenStream, getRichTokenStream,
281 showRichTokenStream, addSourceToTokens,
282
283 -- * Pure interface to the parser
284 parser,
285
286 -- * API Annotations
287 AnnKeywordId(..),EpaComment(..),
288
289 -- * Miscellaneous
290 --sessionHscEnv,
291 cyclicModuleErr,
292 ) where
293
294 {-
295 ToDo:
296
297 * inline bits of GHC.Driver.Main here to simplify layering: hscTcExpr, hscStmt.
298 -}
299
300 import GHC.Prelude hiding (init)
301
302 import GHC.Platform
303 import GHC.Platform.Ways
304
305 import GHC.Driver.Phases ( Phase(..), isHaskellSrcFilename
306 , isSourceFilename, startPhase )
307 import GHC.Driver.Env
308 import GHC.Driver.Errors
309 import GHC.Driver.Errors.Types
310 import GHC.Driver.CmdLine
311 import GHC.Driver.Session
312 import GHC.Driver.Backend
313 import GHC.Driver.Config.Finder (initFinderOpts)
314 import GHC.Driver.Config.Parser (initParserOpts)
315 import GHC.Driver.Config.Logger (initLogFlags)
316 import GHC.Driver.Config.Diagnostic
317 import GHC.Driver.Main
318 import GHC.Driver.Make
319 import GHC.Driver.Hooks
320 import GHC.Driver.Monad
321 import GHC.Driver.Ppr
322
323 import GHC.ByteCode.Types
324 import qualified GHC.Linker.Loader as Loader
325 import GHC.Runtime.Loader
326 import GHC.Runtime.Eval
327 import GHC.Runtime.Interpreter
328 import GHC.Runtime.Context
329 import GHCi.RemoteTypes
330
331 import qualified GHC.Parser as Parser
332 import GHC.Parser.Lexer
333 import GHC.Parser.Annotation
334 import GHC.Parser.Utils
335
336 import GHC.Iface.Load ( loadSysInterface )
337 import GHC.Hs
338 import GHC.Builtin.Types.Prim ( alphaTyVars )
339 import GHC.Iface.Tidy
340 import GHC.Data.StringBuffer
341 import GHC.Data.FastString
342 import qualified GHC.LanguageExtensions as LangExt
343 import GHC.Rename.Names (renamePkgQual, renameRawPkgQual)
344
345 import GHC.Tc.Utils.Monad ( finalSafeMode, fixSafeInstances, initIfaceTcRn )
346 import GHC.Tc.Types
347 import GHC.Tc.Utils.TcType
348 import GHC.Tc.Module
349 import GHC.Tc.Utils.Instantiate
350 import GHC.Tc.Instance.Family
351
352 import GHC.Utils.TmpFs
353 import GHC.SysTools
354 import GHC.SysTools.BaseDir
355
356 import GHC.Utils.Error
357 import GHC.Utils.Monad
358 import GHC.Utils.Misc
359 import GHC.Utils.Outputable
360 import GHC.Utils.Panic
361 import GHC.Utils.Logger
362 import GHC.Utils.Fingerprint
363
364 import GHC.Core.Predicate
365 import GHC.Core.Type hiding( typeKind )
366 import GHC.Core.TyCon
367 import GHC.Core.TyCo.Ppr ( pprForAll )
368 import GHC.Core.Class
369 import GHC.Core.DataCon
370 import GHC.Core.FVs ( orphNamesOfFamInst )
371 import GHC.Core.FamInstEnv ( FamInst, famInstEnvElts )
372 import GHC.Core.InstEnv
373 import GHC.Core
374
375 import GHC.Types.Id
376 import GHC.Types.Name hiding ( varName )
377 import GHC.Types.Avail
378 import GHC.Types.SrcLoc
379 import GHC.Types.TyThing.Ppr ( pprFamInst )
380 import GHC.Types.Annotations
381 import GHC.Types.Name.Set
382 import GHC.Types.Name.Reader
383 import GHC.Types.SourceError
384 import GHC.Types.SafeHaskell
385 import GHC.Types.Error
386 import GHC.Types.Fixity
387 import GHC.Types.Target
388 import GHC.Types.Basic
389 import GHC.Types.TyThing
390 import GHC.Types.Name.Env
391 import GHC.Types.Name.Ppr
392 import GHC.Types.TypeEnv
393 import GHC.Types.BreakInfo
394 import GHC.Types.PkgQual
395
396 import GHC.Unit
397 import GHC.Unit.Env
398 import GHC.Unit.External
399 import GHC.Unit.Finder
400 import GHC.Unit.Module.ModIface
401 import GHC.Unit.Module.ModGuts
402 import GHC.Unit.Module.ModDetails
403 import GHC.Unit.Module.ModSummary
404 import GHC.Unit.Module.Graph
405 import GHC.Unit.Home.ModInfo
406
407 import Data.Foldable
408 import qualified Data.Map.Strict as Map
409 import Data.Set (Set)
410 import qualified Data.Sequence as Seq
411 import Data.Maybe
412 import Data.Typeable ( Typeable )
413 import Data.Word ( Word8 )
414 import Control.Monad
415 import System.Exit ( exitWith, ExitCode(..) )
416 import GHC.Utils.Exception
417 import Data.IORef
418 import System.FilePath
419 import Control.Concurrent
420 import Control.Applicative ((<|>))
421 import Control.Monad.Catch as MC
422
423 import GHC.Data.Maybe
424 import System.IO.Error ( isDoesNotExistError )
425 import System.Environment ( getEnv, getProgName )
426 import System.Directory
427 import Data.List (isPrefixOf)
428
429
430 -- %************************************************************************
431 -- %* *
432 -- Initialisation: exception handlers
433 -- %* *
434 -- %************************************************************************
435
436
437 -- | Install some default exception handlers and run the inner computation.
438 -- Unless you want to handle exceptions yourself, you should wrap this around
439 -- the top level of your program. The default handlers output the error
440 -- message(s) to stderr and exit cleanly.
441 defaultErrorHandler :: (ExceptionMonad m)
442 => FatalMessager -> FlushOut -> m a -> m a
443 defaultErrorHandler fm (FlushOut flushOut) inner =
444 -- top-level exception handler: any unrecognised exception is a compiler bug.
445 MC.handle (\exception -> liftIO $ do
446 flushOut
447 case fromException exception of
448 -- an IO exception probably isn't our fault, so don't panic
449 Just (ioe :: IOException) ->
450 fm (show ioe)
451 _ -> case fromException exception of
452 Just UserInterrupt ->
453 -- Important to let this one propagate out so our
454 -- calling process knows we were interrupted by ^C
455 liftIO $ throwIO UserInterrupt
456 Just StackOverflow ->
457 fm "stack overflow: use +RTS -K<size> to increase it"
458 _ -> case fromException exception of
459 Just (ex :: ExitCode) -> liftIO $ throwIO ex
460 _ ->
461 fm (show (Panic (show exception)))
462 exitWith (ExitFailure 1)
463 ) $
464
465 -- error messages propagated as exceptions
466 handleGhcException
467 (\ge -> liftIO $ do
468 flushOut
469 case ge of
470 Signal _ -> return ()
471 ProgramError _ -> fm (show ge)
472 CmdLineError _ -> fm ("<command line>: " ++ show ge)
473 _ -> do
474 progName <- getProgName
475 fm (progName ++ ": " ++ show ge)
476 exitWith (ExitFailure 1)
477 ) $
478 inner
479
480 -- | This function is no longer necessary, cleanup is now done by
481 -- runGhc/runGhcT.
482 {-# DEPRECATED defaultCleanupHandler "Cleanup is now done by runGhc/runGhcT" #-}
483 defaultCleanupHandler :: (ExceptionMonad m) => DynFlags -> m a -> m a
484 defaultCleanupHandler _ m = m
485 where _warning_suppression = m `MC.onException` undefined
486
487
488 -- %************************************************************************
489 -- %* *
490 -- The Ghc Monad
491 -- %* *
492 -- %************************************************************************
493
494 -- | Run function for the 'Ghc' monad.
495 --
496 -- It initialises the GHC session and warnings via 'initGhcMonad'. Each call
497 -- to this function will create a new session which should not be shared among
498 -- several threads.
499 --
500 -- Any errors not handled inside the 'Ghc' action are propagated as IO
501 -- exceptions.
502
503 runGhc :: Maybe FilePath -- ^ See argument to 'initGhcMonad'.
504 -> Ghc a -- ^ The action to perform.
505 -> IO a
506 runGhc mb_top_dir ghc = do
507 ref <- newIORef (panic "empty session")
508 let session = Session ref
509 flip unGhc session $ withSignalHandlers $ do -- catch ^C
510 initGhcMonad mb_top_dir
511 withCleanupSession ghc
512
513 -- | Run function for 'GhcT' monad transformer.
514 --
515 -- It initialises the GHC session and warnings via 'initGhcMonad'. Each call
516 -- to this function will create a new session which should not be shared among
517 -- several threads.
518
519 runGhcT :: ExceptionMonad m =>
520 Maybe FilePath -- ^ See argument to 'initGhcMonad'.
521 -> GhcT m a -- ^ The action to perform.
522 -> m a
523 runGhcT mb_top_dir ghct = do
524 ref <- liftIO $ newIORef (panic "empty session")
525 let session = Session ref
526 flip unGhcT session $ withSignalHandlers $ do -- catch ^C
527 initGhcMonad mb_top_dir
528 withCleanupSession ghct
529
530 withCleanupSession :: GhcMonad m => m a -> m a
531 withCleanupSession ghc = ghc `MC.finally` cleanup
532 where
533 cleanup = do
534 hsc_env <- getSession
535 let dflags = hsc_dflags hsc_env
536 let logger = hsc_logger hsc_env
537 let tmpfs = hsc_tmpfs hsc_env
538 liftIO $ do
539 unless (gopt Opt_KeepTmpFiles dflags) $ do
540 cleanTempFiles logger tmpfs
541 cleanTempDirs logger tmpfs
542 traverse_ stopInterp (hsc_interp hsc_env)
543 -- exceptions will be blocked while we clean the temporary files,
544 -- so there shouldn't be any difficulty if we receive further
545 -- signals.
546
547 -- | Initialise a GHC session.
548 --
549 -- If you implement a custom 'GhcMonad' you must call this function in the
550 -- monad run function. It will initialise the session variable and clear all
551 -- warnings.
552 --
553 -- The first argument should point to the directory where GHC's library files
554 -- reside. More precisely, this should be the output of @ghc --print-libdir@
555 -- of the version of GHC the module using this API is compiled with. For
556 -- portability, you should use the @ghc-paths@ package, available at
557 -- <http://hackage.haskell.org/package/ghc-paths>.
558
559 initGhcMonad :: GhcMonad m => Maybe FilePath -> m ()
560 initGhcMonad mb_top_dir
561 = do { env <- liftIO $
562 do { top_dir <- findTopDir mb_top_dir
563 ; mySettings <- initSysTools top_dir
564 ; myLlvmConfig <- lazyInitLlvmConfig top_dir
565 ; dflags <- initDynFlags (defaultDynFlags mySettings myLlvmConfig)
566 ; hsc_env <- newHscEnv dflags
567 ; checkBrokenTablesNextToCode (hsc_logger hsc_env) dflags
568 ; setUnsafeGlobalDynFlags dflags
569 -- c.f. DynFlags.parseDynamicFlagsFull, which
570 -- creates DynFlags and sets the UnsafeGlobalDynFlags
571 ; return hsc_env }
572 ; setSession env }
573
574 -- | The binutils linker on ARM emits unnecessary R_ARM_COPY relocations which
575 -- breaks tables-next-to-code in dynamically linked modules. This
576 -- check should be more selective but there is currently no released
577 -- version where this bug is fixed.
578 -- See https://sourceware.org/bugzilla/show_bug.cgi?id=16177 and
579 -- https://gitlab.haskell.org/ghc/ghc/issues/4210#note_78333
580 checkBrokenTablesNextToCode :: MonadIO m => Logger -> DynFlags -> m ()
581 checkBrokenTablesNextToCode logger dflags
582 = do { broken <- checkBrokenTablesNextToCode' logger dflags
583 ; when broken
584 $ do { _ <- liftIO $ throwIO $ mkApiErr dflags invalidLdErr
585 ; liftIO $ fail "unsupported linker"
586 }
587 }
588 where
589 invalidLdErr = text "Tables-next-to-code not supported on ARM" <+>
590 text "when using binutils ld (please see:" <+>
591 text "https://sourceware.org/bugzilla/show_bug.cgi?id=16177)"
592
593 checkBrokenTablesNextToCode' :: MonadIO m => Logger -> DynFlags -> m Bool
594 checkBrokenTablesNextToCode' logger dflags
595 | not (isARM arch) = return False
596 | ways dflags `hasNotWay` WayDyn = return False
597 | not tablesNextToCode = return False
598 | otherwise = do
599 linkerInfo <- liftIO $ getLinkerInfo logger dflags
600 case linkerInfo of
601 GnuLD _ -> return True
602 _ -> return False
603 where platform = targetPlatform dflags
604 arch = platformArch platform
605 tablesNextToCode = platformTablesNextToCode platform
606
607
608 -- %************************************************************************
609 -- %* *
610 -- Flags & settings
611 -- %* *
612 -- %************************************************************************
613
614 -- $DynFlags
615 --
616 -- The GHC session maintains two sets of 'DynFlags':
617 --
618 -- * The "interactive" @DynFlags@, which are used for everything
619 -- related to interactive evaluation, including 'runStmt',
620 -- 'runDecls', 'exprType', 'lookupName' and so on (everything
621 -- under \"Interactive evaluation\" in this module).
622 --
623 -- * The "program" @DynFlags@, which are used when loading
624 -- whole modules with 'load'
625 --
626 -- 'setInteractiveDynFlags', 'getInteractiveDynFlags' work with the
627 -- interactive @DynFlags@.
628 --
629 -- 'setProgramDynFlags', 'getProgramDynFlags' work with the
630 -- program @DynFlags@.
631 --
632 -- 'setSessionDynFlags' sets both @DynFlags@, and 'getSessionDynFlags'
633 -- retrieves the program @DynFlags@ (for backwards compatibility).
634
635
636 -- | Updates both the interactive and program DynFlags in a Session.
637 -- This also reads the package database (unless it has already been
638 -- read), and prepares the compilers knowledge about packages. It can
639 -- be called again to load new packages: just add new package flags to
640 -- (packageFlags dflags).
641 setSessionDynFlags :: GhcMonad m => DynFlags -> m ()
642 setSessionDynFlags dflags0 = do
643 logger <- getLogger
644 dflags1 <- checkNewDynFlags logger dflags0
645 hsc_env <- getSession
646 let old_unit_env = hsc_unit_env hsc_env
647 let cached_unit_dbs = ue_unit_dbs old_unit_env
648 (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 cached_unit_dbs
649
650 dflags <- liftIO $ updatePlatformConstants dflags1 mconstants
651
652 -- Interpreter
653 interp <- if gopt Opt_ExternalInterpreter dflags
654 then do
655 let
656 prog = pgm_i dflags ++ flavour
657 profiled = ways dflags `hasWay` WayProf
658 dynamic = ways dflags `hasWay` WayDyn
659 flavour
660 | profiled = "-prof" -- FIXME: can't we have both?
661 | dynamic = "-dyn"
662 | otherwise = ""
663 msg = text "Starting " <> text prog
664 tr <- if verbosity dflags >= 3
665 then return (logInfo logger $ withPprStyle defaultDumpStyle msg)
666 else return (pure ())
667 let
668 conf = IServConfig
669 { iservConfProgram = prog
670 , iservConfOpts = getOpts dflags opt_i
671 , iservConfProfiled = profiled
672 , iservConfDynamic = dynamic
673 , iservConfHook = createIservProcessHook (hsc_hooks hsc_env)
674 , iservConfTrace = tr
675 }
676 s <- liftIO $ newMVar IServPending
677 loader <- liftIO Loader.uninitializedLoader
678 return (Just (Interp (ExternalInterp conf (IServ s)) loader))
679 else
680 #if defined(HAVE_INTERNAL_INTERPRETER)
681 do
682 loader <- liftIO Loader.uninitializedLoader
683 return (Just (Interp InternalInterp loader))
684 #else
685 return Nothing
686 #endif
687
688 let unit_env = UnitEnv
689 { ue_platform = targetPlatform dflags
690 , ue_namever = ghcNameVersion dflags
691 , ue_home_unit = Just home_unit
692 , ue_hpt = ue_hpt old_unit_env
693 , ue_eps = ue_eps old_unit_env
694 , ue_units = unit_state
695 , ue_unit_dbs = Just dbs
696 }
697
698 modifySession $ \h -> hscSetFlags dflags $
699 h{ hsc_IC = (hsc_IC h){ ic_dflags = dflags }
700 , hsc_interp = hsc_interp h <|> interp
701 -- we only update the interpreter if there wasn't
702 -- already one set up
703 , hsc_unit_env = unit_env
704 }
705
706 invalidateModSummaryCache
707
708 -- | Sets the program 'DynFlags'. Note: this invalidates the internal
709 -- cached module graph, causing more work to be done the next time
710 -- 'load' is called.
711 --
712 -- Returns a boolean indicating if preload units have changed and need to be
713 -- reloaded.
714 setProgramDynFlags :: GhcMonad m => DynFlags -> m Bool
715 setProgramDynFlags dflags = setProgramDynFlags_ True dflags
716
717 setProgramDynFlags_ :: GhcMonad m => Bool -> DynFlags -> m Bool
718 setProgramDynFlags_ invalidate_needed dflags = do
719 logger <- getLogger
720 dflags0 <- checkNewDynFlags logger dflags
721 dflags_prev <- getProgramDynFlags
722 let changed = packageFlagsChanged dflags_prev dflags0
723 if changed
724 then do
725 old_unit_env <- hsc_unit_env <$> getSession
726 let cached_unit_dbs = ue_unit_dbs old_unit_env
727 (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags0 cached_unit_dbs
728
729 dflags1 <- liftIO $ updatePlatformConstants dflags0 mconstants
730
731 let unit_env = UnitEnv
732 { ue_platform = targetPlatform dflags1
733 , ue_namever = ghcNameVersion dflags1
734 , ue_home_unit = Just home_unit
735 , ue_hpt = ue_hpt old_unit_env
736 , ue_eps = ue_eps old_unit_env
737 , ue_units = unit_state
738 , ue_unit_dbs = Just dbs
739 }
740 modifySession $ \h -> hscSetFlags dflags1 $ h{ hsc_unit_env = unit_env }
741 else modifySession (hscSetFlags dflags0)
742
743 when invalidate_needed $ invalidateModSummaryCache
744 return changed
745
746
747 -- When changing the DynFlags, we want the changes to apply to future
748 -- loads, but without completely discarding the program. But the
749 -- DynFlags are cached in each ModSummary in the hsc_mod_graph, so
750 -- after a change to DynFlags, the changes would apply to new modules
751 -- but not existing modules; this seems undesirable.
752 --
753 -- Furthermore, the GHC API client might expect that changing
754 -- log_action would affect future compilation messages, but for those
755 -- modules we have cached ModSummaries for, we'll continue to use the
756 -- old log_action. This is definitely wrong (#7478).
757 --
758 -- Hence, we invalidate the ModSummary cache after changing the
759 -- DynFlags. We do this by tweaking the hash on each ModSummary, so
760 -- that the next downsweep will think that all the files have changed
761 -- and preprocess them again. This won't necessarily cause everything
762 -- to be recompiled, because by the time we check whether we need to
763 -- recompile a module, we'll have re-summarised the module and have a
764 -- correct ModSummary.
765 --
766 invalidateModSummaryCache :: GhcMonad m => m ()
767 invalidateModSummaryCache =
768 modifySession $ \h -> h { hsc_mod_graph = mapMG inval (hsc_mod_graph h) }
769 where
770 inval ms = ms { ms_hs_hash = fingerprint0 }
771
772 -- | Returns the program 'DynFlags'.
773 getProgramDynFlags :: GhcMonad m => m DynFlags
774 getProgramDynFlags = getSessionDynFlags
775
776 -- | Set the 'DynFlags' used to evaluate interactive expressions.
777 -- Also initialise (load) plugins.
778 --
779 -- Note: this cannot be used for changes to packages. Use
780 -- 'setSessionDynFlags', or 'setProgramDynFlags' and then copy the
781 -- 'unitState' into the interactive @DynFlags@.
782 setInteractiveDynFlags :: GhcMonad m => DynFlags -> m ()
783 setInteractiveDynFlags dflags = do
784 logger <- getLogger
785 dflags' <- checkNewDynFlags logger dflags
786 dflags'' <- checkNewInteractiveDynFlags logger dflags'
787 modifySessionM $ \hsc_env0 -> do
788 let ic0 = hsc_IC hsc_env0
789
790 -- Initialise (load) plugins in the interactive environment with the new
791 -- DynFlags
792 plugin_env <- liftIO $ flip initializePlugins Nothing $ mkInteractiveHscEnv $
793 hsc_env0 { hsc_IC = ic0 { ic_dflags = dflags'' }}
794
795 -- Update both plugins cache and DynFlags in the interactive context.
796 return $ hsc_env0
797 { hsc_IC = ic0
798 { ic_plugins = hsc_plugins plugin_env
799 , ic_dflags = hsc_dflags plugin_env
800 }
801 }
802
803
804 -- | Get the 'DynFlags' used to evaluate interactive expressions.
805 getInteractiveDynFlags :: GhcMonad m => m DynFlags
806 getInteractiveDynFlags = withSession $ \h -> return (ic_dflags (hsc_IC h))
807
808
809 parseDynamicFlags
810 :: MonadIO m
811 => Logger
812 -> DynFlags
813 -> [Located String]
814 -> m (DynFlags, [Located String], [Warn])
815 parseDynamicFlags logger dflags cmdline = do
816 (dflags1, leftovers, warns) <- parseDynamicFlagsCmdLine dflags cmdline
817 -- flags that have just been read are used by the logger when loading package
818 -- env (this is checked by T16318)
819 let logger1 = setLogFlags logger (initLogFlags dflags1)
820 dflags2 <- liftIO $ interpretPackageEnv logger1 dflags1
821 return (dflags2, leftovers, warns)
822
823 -- | Parse command line arguments that look like files.
824 -- First normalises its arguments and then splits them into source files
825 -- and object files.
826 -- A source file can be turned into a 'Target' via 'guessTarget'
827 parseTargetFiles :: DynFlags -> [String] -> (DynFlags, [(String, Maybe Phase)], [String])
828 parseTargetFiles dflags0 fileish_args =
829 let
830 normal_fileish_paths = map normalise_hyp fileish_args
831 (srcs, objs) = partition_args normal_fileish_paths [] []
832
833 dflags1 = dflags0 { ldInputs = map (FileOption "") objs
834 ++ ldInputs dflags0 }
835 {-
836 We split out the object files (.o, .dll) and add them
837 to ldInputs for use by the linker.
838
839 The following things should be considered compilation manager inputs:
840
841 - haskell source files (strings ending in .hs, .lhs or other
842 haskellish extension),
843
844 - module names (not forgetting hierarchical module names),
845
846 - things beginning with '-' are flags that were not recognised by
847 the flag parser, and we want them to generate errors later in
848 checkOptions, so we class them as source files (#5921)
849
850 - and finally we consider everything without an extension to be
851 a comp manager input, as shorthand for a .hs or .lhs filename.
852
853 Everything else is considered to be a linker object, and passed
854 straight through to the linker.
855 -}
856 in (dflags1, srcs, objs)
857
858 -- -----------------------------------------------------------------------------
859
860 -- | Splitting arguments into source files and object files. This is where we
861 -- interpret the -x <suffix> option, and attach a (Maybe Phase) to each source
862 -- file indicating the phase specified by the -x option in force, if any.
863 partition_args :: [String] -> [(String, Maybe Phase)] -> [String]
864 -> ([(String, Maybe Phase)], [String])
865 partition_args [] srcs objs = (reverse srcs, reverse objs)
866 partition_args ("-x":suff:args) srcs objs
867 | "none" <- suff = partition_args args srcs objs
868 | StopLn <- phase = partition_args args srcs (slurp ++ objs)
869 | otherwise = partition_args rest (these_srcs ++ srcs) objs
870 where phase = startPhase suff
871 (slurp,rest) = break (== "-x") args
872 these_srcs = zip slurp (repeat (Just phase))
873 partition_args (arg:args) srcs objs
874 | looks_like_an_input arg = partition_args args ((arg,Nothing):srcs) objs
875 | otherwise = partition_args args srcs (arg:objs)
876
877
878 looks_like_an_input :: String -> Bool
879 looks_like_an_input m = isSourceFilename m
880 || looksLikeModuleName m
881 || "-" `isPrefixOf` m
882 || not (hasExtension m)
883
884
885 -- | To simplify the handling of filepaths, we normalise all filepaths right
886 -- away. Note the asymmetry of FilePath.normalise:
887 -- Linux: p\/q -> p\/q; p\\q -> p\\q
888 -- Windows: p\/q -> p\\q; p\\q -> p\\q
889 -- #12674: Filenames starting with a hyphen get normalised from ./-foo.hs
890 -- to -foo.hs. We have to re-prepend the current directory.
891 normalise_hyp :: FilePath -> FilePath
892 normalise_hyp fp
893 | strt_dot_sl && "-" `isPrefixOf` nfp = cur_dir ++ nfp
894 | otherwise = nfp
895 where
896 #if defined(mingw32_HOST_OS)
897 strt_dot_sl = "./" `isPrefixOf` fp || ".\\" `isPrefixOf` fp
898 #else
899 strt_dot_sl = "./" `isPrefixOf` fp
900 #endif
901 cur_dir = '.' : [pathSeparator]
902 nfp = normalise fp
903
904 -----------------------------------------------------------------------------
905
906 -- | Checks the set of new DynFlags for possibly erroneous option
907 -- combinations when invoking 'setSessionDynFlags' and friends, and if
908 -- found, returns a fixed copy (if possible).
909 checkNewDynFlags :: MonadIO m => Logger -> DynFlags -> m DynFlags
910 checkNewDynFlags logger dflags = do
911 -- See Note [DynFlags consistency]
912 let (dflags', warnings) = makeDynFlagsConsistent dflags
913 let diag_opts = initDiagOpts dflags
914 liftIO $ handleFlagWarnings logger diag_opts (map (Warn WarningWithoutFlag) warnings)
915 return dflags'
916
917 checkNewInteractiveDynFlags :: MonadIO m => Logger -> DynFlags -> m DynFlags
918 checkNewInteractiveDynFlags logger dflags0 = do
919 -- We currently don't support use of StaticPointers in expressions entered on
920 -- the REPL. See #12356.
921 if xopt LangExt.StaticPointers dflags0
922 then do
923 let diag_opts = initDiagOpts dflags0
924 liftIO $ printOrThrowDiagnostics logger diag_opts $ singleMessage
925 $ fmap GhcDriverMessage
926 $ mkPlainMsgEnvelope diag_opts interactiveSrcSpan DriverStaticPointersNotSupported
927 return $ xopt_unset dflags0 LangExt.StaticPointers
928 else return dflags0
929
930
931 -- %************************************************************************
932 -- %* *
933 -- Setting, getting, and modifying the targets
934 -- %* *
935 -- %************************************************************************
936
937 -- ToDo: think about relative vs. absolute file paths. And what
938 -- happens when the current directory changes.
939
940 -- | Sets the targets for this session. Each target may be a module name
941 -- or a filename. The targets correspond to the set of root modules for
942 -- the program\/library. Unloading the current program is achieved by
943 -- setting the current set of targets to be empty, followed by 'load'.
944 setTargets :: GhcMonad m => [Target] -> m ()
945 setTargets targets = modifySession (\h -> h{ hsc_targets = targets })
946
947 -- | Returns the current set of targets
948 getTargets :: GhcMonad m => m [Target]
949 getTargets = withSession (return . hsc_targets)
950
951 -- | Add another target.
952 addTarget :: GhcMonad m => Target -> m ()
953 addTarget target
954 = modifySession (\h -> h{ hsc_targets = target : hsc_targets h })
955
956 -- | Remove a target
957 removeTarget :: GhcMonad m => TargetId -> m ()
958 removeTarget target_id
959 = modifySession (\h -> h{ hsc_targets = filter (hsc_targets h) })
960 where
961 filter targets = [ t | t@Target { targetId = id } <- targets, id /= target_id ]
962
963 -- | Attempts to guess what Target a string refers to. This function
964 -- implements the @--make@/GHCi command-line syntax for filenames:
965 --
966 -- - if the string looks like a Haskell source filename, then interpret it
967 -- as such
968 --
969 -- - if adding a .hs or .lhs suffix yields the name of an existing file,
970 -- then use that
971 --
972 -- - otherwise interpret the string as a module name
973 --
974 guessTarget :: GhcMonad m => String -> Maybe UnitId -> Maybe Phase -> m Target
975 guessTarget str mUnitId (Just phase)
976 = do
977 tuid <- unitIdOrHomeUnit mUnitId
978 return (Target (TargetFile str (Just phase)) True tuid Nothing)
979 guessTarget str mUnitId Nothing
980 | isHaskellSrcFilename file
981 = target (TargetFile file Nothing)
982 | otherwise
983 = do exists <- liftIO $ doesFileExist hs_file
984 if exists
985 then target (TargetFile hs_file Nothing)
986 else do
987 exists <- liftIO $ doesFileExist lhs_file
988 if exists
989 then target (TargetFile lhs_file Nothing)
990 else do
991 if looksLikeModuleName file
992 then target (TargetModule (mkModuleName file))
993 else do
994 dflags <- getDynFlags
995 liftIO $ throwGhcExceptionIO
996 (ProgramError (showSDoc dflags $
997 text "target" <+> quotes (text file) <+>
998 text "is not a module name or a source file"))
999 where
1000 (file,obj_allowed)
1001 | '*':rest <- str = (rest, False)
1002 | otherwise = (str, True)
1003
1004 hs_file = file <.> "hs"
1005 lhs_file = file <.> "lhs"
1006
1007 target tid = do
1008 tuid <- unitIdOrHomeUnit mUnitId
1009 pure $ Target tid obj_allowed tuid Nothing
1010
1011 -- | Unwrap 'UnitId' or retrieve the 'UnitId'
1012 -- of the current 'HomeUnit'.
1013 unitIdOrHomeUnit :: GhcMonad m => Maybe UnitId -> m UnitId
1014 unitIdOrHomeUnit mUnitId = do
1015 currentHomeUnitId <- homeUnitId . hsc_home_unit <$> getSession
1016 pure (fromMaybe currentHomeUnitId mUnitId)
1017
1018 -- | Inform GHC that the working directory has changed. GHC will flush
1019 -- its cache of module locations, since it may no longer be valid.
1020 --
1021 -- Note: Before changing the working directory make sure all threads running
1022 -- in the same session have stopped. If you change the working directory,
1023 -- you should also unload the current program (set targets to empty,
1024 -- followed by load).
1025 workingDirectoryChanged :: GhcMonad m => m ()
1026 workingDirectoryChanged = do
1027 hsc_env <- getSession
1028 liftIO $ flushFinderCaches (hsc_FC hsc_env) (hsc_home_unit hsc_env)
1029
1030
1031 -- %************************************************************************
1032 -- %* *
1033 -- Running phases one at a time
1034 -- %* *
1035 -- %************************************************************************
1036
1037 class ParsedMod m where
1038 modSummary :: m -> ModSummary
1039 parsedSource :: m -> ParsedSource
1040
1041 class ParsedMod m => TypecheckedMod m where
1042 renamedSource :: m -> Maybe RenamedSource
1043 typecheckedSource :: m -> TypecheckedSource
1044 moduleInfo :: m -> ModuleInfo
1045 tm_internals :: m -> (TcGblEnv, ModDetails)
1046 -- ToDo: improvements that could be made here:
1047 -- if the module succeeded renaming but not typechecking,
1048 -- we can still get back the GlobalRdrEnv and exports, so
1049 -- perhaps the ModuleInfo should be split up into separate
1050 -- fields.
1051
1052 class TypecheckedMod m => DesugaredMod m where
1053 coreModule :: m -> ModGuts
1054
1055 -- | The result of successful parsing.
1056 data ParsedModule =
1057 ParsedModule { pm_mod_summary :: ModSummary
1058 , pm_parsed_source :: ParsedSource
1059 , pm_extra_src_files :: [FilePath] }
1060
1061 instance ParsedMod ParsedModule where
1062 modSummary m = pm_mod_summary m
1063 parsedSource m = pm_parsed_source m
1064
1065 -- | The result of successful typechecking. It also contains the parser
1066 -- result.
1067 data TypecheckedModule =
1068 TypecheckedModule { tm_parsed_module :: ParsedModule
1069 , tm_renamed_source :: Maybe RenamedSource
1070 , tm_typechecked_source :: TypecheckedSource
1071 , tm_checked_module_info :: ModuleInfo
1072 , tm_internals_ :: (TcGblEnv, ModDetails)
1073 }
1074
1075 instance ParsedMod TypecheckedModule where
1076 modSummary m = modSummary (tm_parsed_module m)
1077 parsedSource m = parsedSource (tm_parsed_module m)
1078
1079 instance TypecheckedMod TypecheckedModule where
1080 renamedSource m = tm_renamed_source m
1081 typecheckedSource m = tm_typechecked_source m
1082 moduleInfo m = tm_checked_module_info m
1083 tm_internals m = tm_internals_ m
1084
1085 -- | The result of successful desugaring (i.e., translation to core). Also
1086 -- contains all the information of a typechecked module.
1087 data DesugaredModule =
1088 DesugaredModule { dm_typechecked_module :: TypecheckedModule
1089 , dm_core_module :: ModGuts
1090 }
1091
1092 instance ParsedMod DesugaredModule where
1093 modSummary m = modSummary (dm_typechecked_module m)
1094 parsedSource m = parsedSource (dm_typechecked_module m)
1095
1096 instance TypecheckedMod DesugaredModule where
1097 renamedSource m = renamedSource (dm_typechecked_module m)
1098 typecheckedSource m = typecheckedSource (dm_typechecked_module m)
1099 moduleInfo m = moduleInfo (dm_typechecked_module m)
1100 tm_internals m = tm_internals_ (dm_typechecked_module m)
1101
1102 instance DesugaredMod DesugaredModule where
1103 coreModule m = dm_core_module m
1104
1105 type ParsedSource = Located HsModule
1106 type RenamedSource = (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [(LIE GhcRn, Avails)],
1107 Maybe LHsDocString)
1108 type TypecheckedSource = LHsBinds GhcTc
1109
1110 -- NOTE:
1111 -- - things that aren't in the output of the typechecker right now:
1112 -- - the export list
1113 -- - the imports
1114 -- - type signatures
1115 -- - type/data/newtype declarations
1116 -- - class declarations
1117 -- - instances
1118 -- - extra things in the typechecker's output:
1119 -- - default methods are turned into top-level decls.
1120 -- - dictionary bindings
1121
1122 -- | Return the 'ModSummary' of a module with the given name.
1123 --
1124 -- The module must be part of the module graph (see 'hsc_mod_graph' and
1125 -- 'ModuleGraph'). If this is not the case, this function will throw a
1126 -- 'GhcApiError'.
1127 --
1128 -- This function ignores boot modules and requires that there is only one
1129 -- non-boot module with the given name.
1130 getModSummary :: GhcMonad m => ModuleName -> m ModSummary
1131 getModSummary mod = do
1132 mg <- liftM hsc_mod_graph getSession
1133 let mods_by_name = [ ms | ms <- mgModSummaries mg
1134 , ms_mod_name ms == mod
1135 , isBootSummary ms == NotBoot ]
1136 case mods_by_name of
1137 [] -> do dflags <- getDynFlags
1138 liftIO $ throwIO $ mkApiErr dflags (text "Module not part of module graph")
1139 [ms] -> return ms
1140 multiple -> do dflags <- getDynFlags
1141 liftIO $ throwIO $ mkApiErr dflags (text "getModSummary is ambiguous: " <+> ppr multiple)
1142
1143 -- | Parse a module.
1144 --
1145 -- Throws a 'SourceError' on parse error.
1146 parseModule :: GhcMonad m => ModSummary -> m ParsedModule
1147 parseModule ms = do
1148 hsc_env <- getSession
1149 liftIO $ do
1150 let lcl_hsc_env = hscSetFlags (ms_hspp_opts ms) hsc_env
1151 hpm <- hscParse lcl_hsc_env ms
1152 return (ParsedModule ms (hpm_module hpm) (hpm_src_files hpm))
1153 -- See Note [exact print annotations] in GHC.Parser.Annotation
1154
1155 -- | Typecheck and rename a parsed module.
1156 --
1157 -- Throws a 'SourceError' if either fails.
1158 typecheckModule :: GhcMonad m => ParsedModule -> m TypecheckedModule
1159 typecheckModule pmod = do
1160 hsc_env <- getSession
1161
1162 liftIO $ do
1163 let ms = modSummary pmod
1164 let lcl_dflags = ms_hspp_opts ms -- take into account pragmas (OPTIONS_GHC, etc.)
1165 let lcl_hsc_env = hscSetFlags lcl_dflags hsc_env
1166 let lcl_logger = hsc_logger lcl_hsc_env
1167 (tc_gbl_env, rn_info) <- hscTypecheckRename lcl_hsc_env ms $
1168 HsParsedModule { hpm_module = parsedSource pmod,
1169 hpm_src_files = pm_extra_src_files pmod }
1170 details <- makeSimpleDetails lcl_logger tc_gbl_env
1171 safe <- finalSafeMode lcl_dflags tc_gbl_env
1172
1173 return $
1174 TypecheckedModule {
1175 tm_internals_ = (tc_gbl_env, details),
1176 tm_parsed_module = pmod,
1177 tm_renamed_source = rn_info,
1178 tm_typechecked_source = tcg_binds tc_gbl_env,
1179 tm_checked_module_info =
1180 ModuleInfo {
1181 minf_type_env = md_types details,
1182 minf_exports = md_exports details,
1183 minf_rdr_env = Just (tcg_rdr_env tc_gbl_env),
1184 minf_instances = fixSafeInstances safe $ md_insts details,
1185 minf_iface = Nothing,
1186 minf_safe = safe,
1187 minf_modBreaks = emptyModBreaks
1188 }}
1189
1190 -- | Desugar a typechecked module.
1191 desugarModule :: GhcMonad m => TypecheckedModule -> m DesugaredModule
1192 desugarModule tcm = do
1193 hsc_env <- getSession
1194 liftIO $ do
1195 let ms = modSummary tcm
1196 let (tcg, _) = tm_internals tcm
1197 let lcl_hsc_env = hscSetFlags (ms_hspp_opts ms) hsc_env
1198 guts <- hscDesugar lcl_hsc_env ms tcg
1199 return $
1200 DesugaredModule {
1201 dm_typechecked_module = tcm,
1202 dm_core_module = guts
1203 }
1204
1205
1206
1207 -- %************************************************************************
1208 -- %* *
1209 -- Dealing with Core
1210 -- %* *
1211 -- %************************************************************************
1212
1213 -- | A CoreModule consists of just the fields of a 'ModGuts' that are needed for
1214 -- the 'GHC.compileToCoreModule' interface.
1215 data CoreModule
1216 = CoreModule {
1217 -- | Module name
1218 cm_module :: !Module,
1219 -- | Type environment for types declared in this module
1220 cm_types :: !TypeEnv,
1221 -- | Declarations
1222 cm_binds :: CoreProgram,
1223 -- | Safe Haskell mode
1224 cm_safe :: SafeHaskellMode
1225 }
1226
1227 instance Outputable CoreModule where
1228 ppr (CoreModule {cm_module = mn, cm_types = te, cm_binds = cb,
1229 cm_safe = sf})
1230 = text "%module" <+> ppr mn <+> parens (ppr sf) <+> ppr te
1231 $$ vcat (map ppr cb)
1232
1233 -- | This is the way to get access to the Core bindings corresponding
1234 -- to a module. 'compileToCore' parses, typechecks, and
1235 -- desugars the module, then returns the resulting Core module (consisting of
1236 -- the module name, type declarations, and function declarations) if
1237 -- successful.
1238 compileToCoreModule :: GhcMonad m => FilePath -> m CoreModule
1239 compileToCoreModule = compileCore False
1240
1241 -- | Like compileToCoreModule, but invokes the simplifier, so
1242 -- as to return simplified and tidied Core.
1243 compileToCoreSimplified :: GhcMonad m => FilePath -> m CoreModule
1244 compileToCoreSimplified = compileCore True
1245
1246 compileCore :: GhcMonad m => Bool -> FilePath -> m CoreModule
1247 compileCore simplify fn = do
1248 -- First, set the target to the desired filename
1249 target <- guessTarget fn Nothing Nothing
1250 addTarget target
1251 _ <- load LoadAllTargets
1252 -- Then find dependencies
1253 modGraph <- depanal [] True
1254 case find ((== fn) . msHsFilePath) (mgModSummaries modGraph) of
1255 Just modSummary -> do
1256 -- Now we have the module name;
1257 -- parse, typecheck and desugar the module
1258 (tcg, mod_guts) <- -- TODO: space leaky: call hsc* directly?
1259 do tm <- typecheckModule =<< parseModule modSummary
1260 let tcg = fst (tm_internals tm)
1261 (,) tcg . coreModule <$> desugarModule tm
1262 liftM (gutsToCoreModule (mg_safe_haskell mod_guts)) $
1263 if simplify
1264 then do
1265 -- If simplify is true: simplify (hscSimplify), then tidy
1266 -- (tidyProgram).
1267 hsc_env <- getSession
1268 simpl_guts <- liftIO $ do
1269 plugins <- readIORef (tcg_th_coreplugins tcg)
1270 hscSimplify hsc_env plugins mod_guts
1271 tidy_guts <- liftIO $ tidyProgram hsc_env simpl_guts
1272 return $ Left tidy_guts
1273 else
1274 return $ Right mod_guts
1275
1276 Nothing -> panic "compileToCoreModule: target FilePath not found in\
1277 module dependency graph"
1278 where -- two versions, based on whether we simplify (thus run tidyProgram,
1279 -- which returns a (CgGuts, ModDetails) pair, or not (in which case
1280 -- we just have a ModGuts.
1281 gutsToCoreModule :: SafeHaskellMode
1282 -> Either (CgGuts, ModDetails) ModGuts
1283 -> CoreModule
1284 gutsToCoreModule safe_mode (Left (cg, md)) = CoreModule {
1285 cm_module = cg_module cg,
1286 cm_types = md_types md,
1287 cm_binds = cg_binds cg,
1288 cm_safe = safe_mode
1289 }
1290 gutsToCoreModule safe_mode (Right mg) = CoreModule {
1291 cm_module = mg_module mg,
1292 cm_types = typeEnvFromEntities (bindersOfBinds (mg_binds mg))
1293 (mg_tcs mg) (mg_patsyns mg)
1294 (mg_fam_insts mg),
1295 cm_binds = mg_binds mg,
1296 cm_safe = safe_mode
1297 }
1298
1299 -- %************************************************************************
1300 -- %* *
1301 -- Inspecting the session
1302 -- %* *
1303 -- %************************************************************************
1304
1305 -- | Get the module dependency graph.
1306 getModuleGraph :: GhcMonad m => m ModuleGraph -- ToDo: DiGraph ModSummary
1307 getModuleGraph = liftM hsc_mod_graph getSession
1308
1309 -- | Return @True@ \<==> module is loaded.
1310 isLoaded :: GhcMonad m => ModuleName -> m Bool
1311 isLoaded m = withSession $ \hsc_env ->
1312 return $! isJust (lookupHpt (hsc_HPT hsc_env) m)
1313
1314 -- | Return the bindings for the current interactive session.
1315 getBindings :: GhcMonad m => m [TyThing]
1316 getBindings = withSession $ \hsc_env ->
1317 return $ icInScopeTTs $ hsc_IC hsc_env
1318
1319 -- | Return the instances for the current interactive session.
1320 getInsts :: GhcMonad m => m ([ClsInst], [FamInst])
1321 getInsts = withSession $ \hsc_env ->
1322 return $ ic_instances (hsc_IC hsc_env)
1323
1324 getPrintUnqual :: GhcMonad m => m PrintUnqualified
1325 getPrintUnqual = withSession $ \hsc_env -> do
1326 return $ icPrintUnqual (hsc_unit_env hsc_env) (hsc_IC hsc_env)
1327
1328 -- | Container for information about a 'Module'.
1329 data ModuleInfo = ModuleInfo {
1330 minf_type_env :: TypeEnv,
1331 minf_exports :: [AvailInfo],
1332 minf_rdr_env :: Maybe GlobalRdrEnv, -- Nothing for a compiled/package mod
1333 minf_instances :: [ClsInst],
1334 minf_iface :: Maybe ModIface,
1335 minf_safe :: SafeHaskellMode,
1336 minf_modBreaks :: ModBreaks
1337 }
1338 -- We don't want HomeModInfo here, because a ModuleInfo applies
1339 -- to package modules too.
1340
1341 -- | Request information about a loaded 'Module'
1342 getModuleInfo :: GhcMonad m => Module -> m (Maybe ModuleInfo) -- XXX: Maybe X
1343 getModuleInfo mdl = withSession $ \hsc_env -> do
1344 let mg = hsc_mod_graph hsc_env
1345 if mgElemModule mg mdl
1346 then liftIO $ getHomeModuleInfo hsc_env mdl
1347 else do
1348 {- if isHomeModule (hsc_dflags hsc_env) mdl
1349 then return Nothing
1350 else -} liftIO $ getPackageModuleInfo hsc_env mdl
1351 -- ToDo: we don't understand what the following comment means.
1352 -- (SDM, 19/7/2011)
1353 -- getPackageModuleInfo will attempt to find the interface, so
1354 -- we don't want to call it for a home module, just in case there
1355 -- was a problem loading the module and the interface doesn't
1356 -- exist... hence the isHomeModule test here. (ToDo: reinstate)
1357
1358 getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
1359 getPackageModuleInfo hsc_env mdl
1360 = do eps <- hscEPS hsc_env
1361 iface <- hscGetModuleInterface hsc_env mdl
1362 let
1363 avails = mi_exports iface
1364 pte = eps_PTE eps
1365 tys = [ ty | name <- concatMap availNames avails,
1366 Just ty <- [lookupTypeEnv pte name] ]
1367 --
1368 return (Just (ModuleInfo {
1369 minf_type_env = mkTypeEnv tys,
1370 minf_exports = avails,
1371 minf_rdr_env = Just $! availsToGlobalRdrEnv (moduleName mdl) avails,
1372 minf_instances = error "getModuleInfo: instances for package module unimplemented",
1373 minf_iface = Just iface,
1374 minf_safe = getSafeMode $ mi_trust iface,
1375 minf_modBreaks = emptyModBreaks
1376 }))
1377
1378 availsToGlobalRdrEnv :: ModuleName -> [AvailInfo] -> GlobalRdrEnv
1379 availsToGlobalRdrEnv mod_name avails
1380 = mkGlobalRdrEnv (gresFromAvails (Just imp_spec) avails)
1381 where
1382 -- We're building a GlobalRdrEnv as if the user imported
1383 -- all the specified modules into the global interactive module
1384 imp_spec = ImpSpec { is_decl = decl, is_item = ImpAll}
1385 decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name,
1386 is_qual = False,
1387 is_dloc = srcLocSpan interactiveSrcLoc }
1388
1389
1390 getHomeModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
1391 getHomeModuleInfo hsc_env mdl =
1392 case lookupHpt (hsc_HPT hsc_env) (moduleName mdl) of
1393 Nothing -> return Nothing
1394 Just hmi -> do
1395 let details = hm_details hmi
1396 iface = hm_iface hmi
1397 return (Just (ModuleInfo {
1398 minf_type_env = md_types details,
1399 minf_exports = md_exports details,
1400 minf_rdr_env = mi_globals $! hm_iface hmi,
1401 minf_instances = md_insts details,
1402 minf_iface = Just iface,
1403 minf_safe = getSafeMode $ mi_trust iface
1404 ,minf_modBreaks = getModBreaks hmi
1405 }))
1406
1407 -- | The list of top-level entities defined in a module
1408 modInfoTyThings :: ModuleInfo -> [TyThing]
1409 modInfoTyThings minf = typeEnvElts (minf_type_env minf)
1410
1411 modInfoTopLevelScope :: ModuleInfo -> Maybe [Name]
1412 modInfoTopLevelScope minf
1413 = fmap (map greMangledName . globalRdrEnvElts) (minf_rdr_env minf)
1414
1415 modInfoExports :: ModuleInfo -> [Name]
1416 modInfoExports minf = concatMap availNames $! minf_exports minf
1417
1418 modInfoExportsWithSelectors :: ModuleInfo -> [Name]
1419 modInfoExportsWithSelectors minf = concatMap availNamesWithSelectors $! minf_exports minf
1420
1421 -- | Returns the instances defined by the specified module.
1422 -- Warning: currently unimplemented for package modules.
1423 modInfoInstances :: ModuleInfo -> [ClsInst]
1424 modInfoInstances = minf_instances
1425
1426 modInfoIsExportedName :: ModuleInfo -> Name -> Bool
1427 modInfoIsExportedName minf name = elemNameSet name (availsToNameSet (minf_exports minf))
1428
1429 mkPrintUnqualifiedForModule :: GhcMonad m =>
1430 ModuleInfo
1431 -> m (Maybe PrintUnqualified) -- XXX: returns a Maybe X
1432 mkPrintUnqualifiedForModule minf = withSession $ \hsc_env -> do
1433 let mk_print_unqual = mkPrintUnqualified (hsc_unit_env hsc_env)
1434 return (fmap mk_print_unqual (minf_rdr_env minf))
1435
1436 modInfoLookupName :: GhcMonad m =>
1437 ModuleInfo -> Name
1438 -> m (Maybe TyThing) -- XXX: returns a Maybe X
1439 modInfoLookupName minf name = withSession $ \hsc_env -> do
1440 case lookupTypeEnv (minf_type_env minf) name of
1441 Just tyThing -> return (Just tyThing)
1442 Nothing -> liftIO (lookupType hsc_env name)
1443
1444 modInfoIface :: ModuleInfo -> Maybe ModIface
1445 modInfoIface = minf_iface
1446
1447 modInfoRdrEnv :: ModuleInfo -> Maybe GlobalRdrEnv
1448 modInfoRdrEnv = minf_rdr_env
1449
1450 -- | Retrieve module safe haskell mode
1451 modInfoSafe :: ModuleInfo -> SafeHaskellMode
1452 modInfoSafe = minf_safe
1453
1454 modInfoModBreaks :: ModuleInfo -> ModBreaks
1455 modInfoModBreaks = minf_modBreaks
1456
1457 isDictonaryId :: Id -> Bool
1458 isDictonaryId id
1459 = case tcSplitSigmaTy (idType id) of {
1460 (_tvs, _theta, tau) -> isDictTy tau }
1461
1462 -- | Looks up a global name: that is, any top-level name in any
1463 -- visible module. Unlike 'lookupName', lookupGlobalName does not use
1464 -- the interactive context, and therefore does not require a preceding
1465 -- 'setContext'.
1466 lookupGlobalName :: GhcMonad m => Name -> m (Maybe TyThing)
1467 lookupGlobalName name = withSession $ \hsc_env -> do
1468 liftIO $ lookupType hsc_env name
1469
1470 findGlobalAnns :: (GhcMonad m, Typeable a) => ([Word8] -> a) -> AnnTarget Name -> m [a]
1471 findGlobalAnns deserialize target = withSession $ \hsc_env -> do
1472 ann_env <- liftIO $ prepareAnnotations hsc_env Nothing
1473 return (findAnns deserialize ann_env target)
1474
1475 -- | get the GlobalRdrEnv for a session
1476 getGRE :: GhcMonad m => m GlobalRdrEnv
1477 getGRE = withSession $ \hsc_env-> return $ icReaderEnv (hsc_IC hsc_env)
1478
1479 -- | Retrieve all type and family instances in the environment, indexed
1480 -- by 'Name'. Each name's lists will contain every instance in which that name
1481 -- is mentioned in the instance head.
1482 getNameToInstancesIndex :: GhcMonad m
1483 => [Module] -- ^ visible modules. An orphan instance will be returned
1484 -- if it is visible from at least one module in the list.
1485 -> Maybe [Module] -- ^ modules to load. If this is not specified, we load
1486 -- modules for everything that is in scope unqualified.
1487 -> m (Messages TcRnMessage, Maybe (NameEnv ([ClsInst], [FamInst])))
1488 getNameToInstancesIndex visible_mods mods_to_load = do
1489 hsc_env <- getSession
1490 liftIO $ runTcInteractive hsc_env $
1491 do { case mods_to_load of
1492 Nothing -> loadUnqualIfaces hsc_env (hsc_IC hsc_env)
1493 Just mods ->
1494 let doc = text "Need interface for reporting instances in scope"
1495 in initIfaceTcRn $ mapM_ (loadSysInterface doc) mods
1496
1497 ; InstEnvs {ie_global, ie_local} <- tcGetInstEnvs
1498 ; let visible_mods' = mkModuleSet visible_mods
1499 ; (pkg_fie, home_fie) <- tcGetFamInstEnvs
1500 -- We use Data.Sequence.Seq because we are creating left associated
1501 -- mappends.
1502 -- cls_index and fam_index below are adapted from GHC.Tc.Module.lookupInsts
1503 ; let cls_index = Map.fromListWith mappend
1504 [ (n, Seq.singleton ispec)
1505 | ispec <- instEnvElts ie_local ++ instEnvElts ie_global
1506 , instIsVisible visible_mods' ispec
1507 , n <- nameSetElemsStable $ orphNamesOfClsInst ispec
1508 ]
1509 ; let fam_index = Map.fromListWith mappend
1510 [ (n, Seq.singleton fispec)
1511 | fispec <- famInstEnvElts home_fie ++ famInstEnvElts pkg_fie
1512 , n <- nameSetElemsStable $ orphNamesOfFamInst fispec
1513 ]
1514 ; return $ mkNameEnv $
1515 [ (nm, (toList clss, toList fams))
1516 | (nm, (clss, fams)) <- Map.toList $ Map.unionWith mappend
1517 (fmap (,Seq.empty) cls_index)
1518 (fmap (Seq.empty,) fam_index)
1519 ] }
1520
1521 -- -----------------------------------------------------------------------------
1522 -- Misc exported utils
1523
1524 dataConType :: DataCon -> Type
1525 dataConType dc = idType (dataConWrapId dc)
1526
1527 -- | print a 'NamedThing', adding parentheses if the name is an operator.
1528 pprParenSymName :: NamedThing a => a -> SDoc
1529 pprParenSymName a = parenSymOcc (getOccName a) (ppr (getName a))
1530
1531 -- ----------------------------------------------------------------------------
1532
1533
1534 -- ToDo:
1535 -- - Data and Typeable instances for HsSyn.
1536
1537 -- ToDo: check for small transformations that happen to the syntax in
1538 -- the typechecker (eg. -e ==> negate e, perhaps for fromIntegral)
1539
1540 -- ToDo: maybe use TH syntax instead of Iface syntax? There's already a way
1541 -- to get from TyCons, Ids etc. to TH syntax (reify).
1542
1543 -- :browse will use either lm_toplev or inspect lm_interface, depending
1544 -- on whether the module is interpreted or not.
1545
1546
1547 -- Extract the filename, stringbuffer content and dynflags associed to a ModSummary
1548 -- Given an initialised GHC session a ModSummary can be retrieved for
1549 -- a module by using 'getModSummary'
1550 --
1551 -- XXX: Explain pre-conditions
1552 getModuleSourceAndFlags :: ModSummary -> IO (String, StringBuffer, DynFlags)
1553 getModuleSourceAndFlags m = do
1554 case ml_hs_file $ ms_location m of
1555 Nothing -> throwIO $ mkApiErr (ms_hspp_opts m) (text "No source available for module " <+> ppr (ms_mod m))
1556 Just sourceFile -> do
1557 source <- hGetStringBuffer sourceFile
1558 return (sourceFile, source, ms_hspp_opts m)
1559
1560
1561 -- | Return module source as token stream, including comments.
1562 --
1563 -- A 'Module' can be turned into a 'ModSummary' using 'getModSummary' if
1564 -- your session is fully initialised.
1565 -- Throws a 'GHC.Driver.Env.SourceError' on parse error.
1566 getTokenStream :: ModSummary -> IO [Located Token]
1567 getTokenStream mod = do
1568 (sourceFile, source, dflags) <- getModuleSourceAndFlags mod
1569 let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1
1570 case lexTokenStream (initParserOpts dflags) source startLoc of
1571 POk _ ts -> return ts
1572 PFailed pst -> throwErrors (GhcPsMessage <$> getPsErrorMessages pst)
1573
1574 -- | Give even more information on the source than 'getTokenStream'
1575 -- This function allows reconstructing the source completely with
1576 -- 'showRichTokenStream'.
1577 getRichTokenStream :: ModSummary -> IO [(Located Token, String)]
1578 getRichTokenStream mod = do
1579 (sourceFile, source, dflags) <- getModuleSourceAndFlags mod
1580 let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1
1581 case lexTokenStream (initParserOpts dflags) source startLoc of
1582 POk _ ts -> return $ addSourceToTokens startLoc source ts
1583 PFailed pst -> throwErrors (GhcPsMessage <$> getPsErrorMessages pst)
1584
1585 -- | Given a source location and a StringBuffer corresponding to this
1586 -- location, return a rich token stream with the source associated to the
1587 -- tokens.
1588 addSourceToTokens :: RealSrcLoc -> StringBuffer -> [Located Token]
1589 -> [(Located Token, String)]
1590 addSourceToTokens _ _ [] = []
1591 addSourceToTokens loc buf (t@(L span _) : ts)
1592 = case span of
1593 UnhelpfulSpan _ -> (t,"") : addSourceToTokens loc buf ts
1594 RealSrcSpan s _ -> (t,str) : addSourceToTokens newLoc newBuf ts
1595 where
1596 (newLoc, newBuf, str) = go "" loc buf
1597 start = realSrcSpanStart s
1598 end = realSrcSpanEnd s
1599 go acc loc buf | loc < start = go acc nLoc nBuf
1600 | start <= loc && loc < end = go (ch:acc) nLoc nBuf
1601 | otherwise = (loc, buf, reverse acc)
1602 where (ch, nBuf) = nextChar buf
1603 nLoc = advanceSrcLoc loc ch
1604
1605
1606 -- | Take a rich token stream such as produced from 'getRichTokenStream' and
1607 -- return source code almost identical to the original code (except for
1608 -- insignificant whitespace.)
1609 showRichTokenStream :: [(Located Token, String)] -> String
1610 showRichTokenStream ts = go startLoc ts ""
1611 where sourceFile = getFile $ map (getLoc . fst) ts
1612 getFile [] = panic "showRichTokenStream: No source file found"
1613 getFile (UnhelpfulSpan _ : xs) = getFile xs
1614 getFile (RealSrcSpan s _ : _) = srcSpanFile s
1615 startLoc = mkRealSrcLoc sourceFile 1 1
1616 go _ [] = id
1617 go loc ((L span _, str):ts)
1618 = case span of
1619 UnhelpfulSpan _ -> go loc ts
1620 RealSrcSpan s _
1621 | locLine == tokLine -> ((replicate (tokCol - locCol) ' ') ++)
1622 . (str ++)
1623 . go tokEnd ts
1624 | otherwise -> ((replicate (tokLine - locLine) '\n') ++)
1625 . ((replicate (tokCol - 1) ' ') ++)
1626 . (str ++)
1627 . go tokEnd ts
1628 where (locLine, locCol) = (srcLocLine loc, srcLocCol loc)
1629 (tokLine, tokCol) = (srcSpanStartLine s, srcSpanStartCol s)
1630 tokEnd = realSrcSpanEnd s
1631
1632 -- -----------------------------------------------------------------------------
1633 -- Interactive evaluation
1634
1635 -- | Takes a 'ModuleName' and possibly a 'UnitId', and consults the
1636 -- filesystem and package database to find the corresponding 'Module',
1637 -- using the algorithm that is used for an @import@ declaration.
1638 findModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module
1639 findModule mod_name maybe_pkg = do
1640 pkg_qual <- renamePkgQualM maybe_pkg
1641 findQualifiedModule pkg_qual mod_name
1642
1643
1644 findQualifiedModule :: GhcMonad m => PkgQual -> ModuleName -> m Module
1645 findQualifiedModule pkgqual mod_name = withSession $ \hsc_env -> do
1646 let fc = hsc_FC hsc_env
1647 let home_unit = hsc_home_unit hsc_env
1648 let units = hsc_units hsc_env
1649 let dflags = hsc_dflags hsc_env
1650 let fopts = initFinderOpts dflags
1651 case pkgqual of
1652 ThisPkg _ -> do
1653 home <- lookupLoadedHomeModule mod_name
1654 case home of
1655 Just m -> return m
1656 Nothing -> liftIO $ do
1657 res <- findImportedModule fc fopts units home_unit mod_name pkgqual
1658 case res of
1659 Found loc m | not (isHomeModule home_unit m) -> return m
1660 | otherwise -> modNotLoadedError dflags m loc
1661 err -> throwOneError $ noModError hsc_env noSrcSpan mod_name err
1662
1663 _ -> liftIO $ do
1664 res <- findImportedModule fc fopts units home_unit mod_name pkgqual
1665 case res of
1666 Found _ m -> return m
1667 err -> throwOneError $ noModError hsc_env noSrcSpan mod_name err
1668
1669
1670 modNotLoadedError :: DynFlags -> Module -> ModLocation -> IO a
1671 modNotLoadedError dflags m loc = throwGhcExceptionIO $ CmdLineError $ showSDoc dflags $
1672 text "module is not loaded:" <+>
1673 quotes (ppr (moduleName m)) <+>
1674 parens (text (expectJust "modNotLoadedError" (ml_hs_file loc)))
1675
1676 renamePkgQualM :: GhcMonad m => Maybe FastString -> m PkgQual
1677 renamePkgQualM p = withSession $ \hsc_env -> pure (renamePkgQual (hsc_unit_env hsc_env) p)
1678
1679 renameRawPkgQualM :: GhcMonad m => RawPkgQual -> m PkgQual
1680 renameRawPkgQualM p = withSession $ \hsc_env -> pure (renameRawPkgQual (hsc_unit_env hsc_env) p)
1681
1682 -- | Like 'findModule', but differs slightly when the module refers to
1683 -- a source file, and the file has not been loaded via 'load'. In
1684 -- this case, 'findModule' will throw an error (module not loaded),
1685 -- but 'lookupModule' will check to see whether the module can also be
1686 -- found in a package, and if so, that package 'Module' will be
1687 -- returned. If not, the usual module-not-found error will be thrown.
1688 --
1689 lookupModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module
1690 lookupModule mod_name maybe_pkg = do
1691 pkgqual <- renamePkgQualM maybe_pkg
1692 lookupQualifiedModule pkgqual mod_name
1693
1694 lookupQualifiedModule :: GhcMonad m => PkgQual -> ModuleName -> m Module
1695 lookupQualifiedModule NoPkgQual mod_name = withSession $ \hsc_env -> do
1696 home <- lookupLoadedHomeModule mod_name
1697 case home of
1698 Just m -> return m
1699 Nothing -> liftIO $ do
1700 let fc = hsc_FC hsc_env
1701 let units = hsc_units hsc_env
1702 let dflags = hsc_dflags hsc_env
1703 let fopts = initFinderOpts dflags
1704 res <- findExposedPackageModule fc fopts units mod_name NoPkgQual
1705 case res of
1706 Found _ m -> return m
1707 err -> throwOneError $ noModError hsc_env noSrcSpan mod_name err
1708 lookupQualifiedModule pkgqual mod_name = findQualifiedModule pkgqual mod_name
1709
1710 lookupLoadedHomeModule :: GhcMonad m => ModuleName -> m (Maybe Module)
1711 lookupLoadedHomeModule mod_name = withSession $ \hsc_env ->
1712 case lookupHpt (hsc_HPT hsc_env) mod_name of
1713 Just mod_info -> return (Just (mi_module (hm_iface mod_info)))
1714 _not_a_home_module -> return Nothing
1715
1716 -- | Check that a module is safe to import (according to Safe Haskell).
1717 --
1718 -- We return True to indicate the import is safe and False otherwise
1719 -- although in the False case an error may be thrown first.
1720 isModuleTrusted :: GhcMonad m => Module -> m Bool
1721 isModuleTrusted m = withSession $ \hsc_env ->
1722 liftIO $ hscCheckSafe hsc_env m noSrcSpan
1723
1724 -- | Return if a module is trusted and the pkgs it depends on to be trusted.
1725 moduleTrustReqs :: GhcMonad m => Module -> m (Bool, Set UnitId)
1726 moduleTrustReqs m = withSession $ \hsc_env ->
1727 liftIO $ hscGetSafe hsc_env m noSrcSpan
1728
1729 -- | Set the monad GHCi lifts user statements into.
1730 --
1731 -- Checks that a type (in string form) is an instance of the
1732 -- @GHC.GHCi.GHCiSandboxIO@ type class. Sets it to be the GHCi monad if it is,
1733 -- throws an error otherwise.
1734 setGHCiMonad :: GhcMonad m => String -> m ()
1735 setGHCiMonad name = withSession $ \hsc_env -> do
1736 ty <- liftIO $ hscIsGHCiMonad hsc_env name
1737 modifySession $ \s ->
1738 let ic = (hsc_IC s) { ic_monad = ty }
1739 in s { hsc_IC = ic }
1740
1741 -- | Get the monad GHCi lifts user statements into.
1742 getGHCiMonad :: GhcMonad m => m Name
1743 getGHCiMonad = fmap (ic_monad . hsc_IC) getSession
1744
1745 getHistorySpan :: GhcMonad m => History -> m SrcSpan
1746 getHistorySpan h = withSession $ \hsc_env ->
1747 return $ GHC.Runtime.Eval.getHistorySpan hsc_env h
1748
1749 obtainTermFromVal :: GhcMonad m => Int -> Bool -> Type -> a -> m Term
1750 obtainTermFromVal bound force ty a = withSession $ \hsc_env ->
1751 liftIO $ GHC.Runtime.Eval.obtainTermFromVal hsc_env bound force ty a
1752
1753 obtainTermFromId :: GhcMonad m => Int -> Bool -> Id -> m Term
1754 obtainTermFromId bound force id = withSession $ \hsc_env ->
1755 liftIO $ GHC.Runtime.Eval.obtainTermFromId hsc_env bound force id
1756
1757
1758 -- | Returns the 'TyThing' for a 'Name'. The 'Name' may refer to any
1759 -- entity known to GHC, including 'Name's defined using 'runStmt'.
1760 lookupName :: GhcMonad m => Name -> m (Maybe TyThing)
1761 lookupName name =
1762 withSession $ \hsc_env ->
1763 liftIO $ hscTcRcLookupName hsc_env name
1764
1765 -- -----------------------------------------------------------------------------
1766 -- Pure API
1767
1768 -- | A pure interface to the module parser.
1769 --
1770 parser :: String -- ^ Haskell module source text (full Unicode is supported)
1771 -> DynFlags -- ^ the flags
1772 -> FilePath -- ^ the filename (for source locations)
1773 -> (WarningMessages, Either ErrorMessages (Located HsModule))
1774
1775 parser str dflags filename =
1776 let
1777 loc = mkRealSrcLoc (mkFastString filename) 1 1
1778 buf = stringToStringBuffer str
1779 in
1780 case unP Parser.parseModule (initParserState (initParserOpts dflags) buf loc) of
1781
1782 PFailed pst ->
1783 let (warns,errs) = getPsMessages pst in
1784 (GhcPsMessage <$> warns, Left $ GhcPsMessage <$> errs)
1785
1786 POk pst rdr_module ->
1787 let (warns,_) = getPsMessages pst in
1788 (GhcPsMessage <$> warns, Right rdr_module)
1789
1790 -- -----------------------------------------------------------------------------
1791 -- | Find the package environment (if one exists)
1792 --
1793 -- We interpret the package environment as a set of package flags; to be
1794 -- specific, if we find a package environment file like
1795 --
1796 -- > clear-package-db
1797 -- > global-package-db
1798 -- > package-db blah/package.conf.d
1799 -- > package-id id1
1800 -- > package-id id2
1801 --
1802 -- we interpret this as
1803 --
1804 -- > [ -hide-all-packages
1805 -- > , -clear-package-db
1806 -- > , -global-package-db
1807 -- > , -package-db blah/package.conf.d
1808 -- > , -package-id id1
1809 -- > , -package-id id2
1810 -- > ]
1811 --
1812 -- There's also an older syntax alias for package-id, which is just an
1813 -- unadorned package id
1814 --
1815 -- > id1
1816 -- > id2
1817 --
1818 interpretPackageEnv :: Logger -> DynFlags -> IO DynFlags
1819 interpretPackageEnv logger dflags = do
1820 mPkgEnv <- runMaybeT $ msum $ [
1821 getCmdLineArg >>= \env -> msum [
1822 probeNullEnv env
1823 , probeEnvFile env
1824 , probeEnvName env
1825 , cmdLineError env
1826 ]
1827 , getEnvVar >>= \env -> msum [
1828 probeNullEnv env
1829 , probeEnvFile env
1830 , probeEnvName env
1831 , envError env
1832 ]
1833 , notIfHideAllPackages >> msum [
1834 findLocalEnvFile >>= probeEnvFile
1835 , probeEnvName defaultEnvName
1836 ]
1837 ]
1838 case mPkgEnv of
1839 Nothing ->
1840 -- No environment found. Leave DynFlags unchanged.
1841 return dflags
1842 Just "-" -> do
1843 -- Explicitly disabled environment file. Leave DynFlags unchanged.
1844 return dflags
1845 Just envfile -> do
1846 content <- readFile envfile
1847 compilationProgressMsg logger (text "Loaded package environment from " <> text envfile)
1848 let (_, dflags') = runCmdLine (runEwM (setFlagsFromEnvFile envfile content)) dflags
1849
1850 return dflags'
1851 where
1852 -- Loading environments (by name or by location)
1853
1854 archOS = platformArchOS (targetPlatform dflags)
1855
1856 namedEnvPath :: String -> MaybeT IO FilePath
1857 namedEnvPath name = do
1858 appdir <- versionedAppDir (programName dflags) archOS
1859 return $ appdir </> "environments" </> name
1860
1861 probeEnvName :: String -> MaybeT IO FilePath
1862 probeEnvName name = probeEnvFile =<< namedEnvPath name
1863
1864 probeEnvFile :: FilePath -> MaybeT IO FilePath
1865 probeEnvFile path = do
1866 guard =<< liftMaybeT (doesFileExist path)
1867 return path
1868
1869 probeNullEnv :: FilePath -> MaybeT IO FilePath
1870 probeNullEnv "-" = return "-"
1871 probeNullEnv _ = mzero
1872
1873 -- Various ways to define which environment to use
1874
1875 getCmdLineArg :: MaybeT IO String
1876 getCmdLineArg = MaybeT $ return $ packageEnv dflags
1877
1878 getEnvVar :: MaybeT IO String
1879 getEnvVar = do
1880 mvar <- liftMaybeT $ MC.try $ getEnv "GHC_ENVIRONMENT"
1881 case mvar of
1882 Right var -> return var
1883 Left err -> if isDoesNotExistError err then mzero
1884 else liftMaybeT $ throwIO err
1885
1886 notIfHideAllPackages :: MaybeT IO ()
1887 notIfHideAllPackages =
1888 guard (not (gopt Opt_HideAllPackages dflags))
1889
1890 defaultEnvName :: String
1891 defaultEnvName = "default"
1892
1893 -- e.g. .ghc.environment.x86_64-linux-7.6.3
1894 localEnvFileName :: FilePath
1895 localEnvFileName = ".ghc.environment" <.> versionedFilePath archOS
1896
1897 -- Search for an env file, starting in the current dir and looking upwards.
1898 -- Fail if we get to the users home dir or the filesystem root. That is,
1899 -- we don't look for an env file in the user's home dir. The user-wide
1900 -- env lives in ghc's versionedAppDir/environments/default
1901 findLocalEnvFile :: MaybeT IO FilePath
1902 findLocalEnvFile = do
1903 curdir <- liftMaybeT getCurrentDirectory
1904 homedir <- tryMaybeT getHomeDirectory
1905 let probe dir | isDrive dir || dir == homedir
1906 = mzero
1907 probe dir = do
1908 let file = dir </> localEnvFileName
1909 exists <- liftMaybeT (doesFileExist file)
1910 if exists
1911 then return file
1912 else probe (takeDirectory dir)
1913 probe curdir
1914
1915 -- Error reporting
1916
1917 cmdLineError :: String -> MaybeT IO a
1918 cmdLineError env = liftMaybeT . throwGhcExceptionIO . CmdLineError $
1919 "Package environment " ++ show env ++ " not found"
1920
1921 envError :: String -> MaybeT IO a
1922 envError env = liftMaybeT . throwGhcExceptionIO . CmdLineError $
1923 "Package environment "
1924 ++ show env
1925 ++ " (specified in GHC_ENVIRONMENT) not found"
1926
1927 -- | An error thrown if the GHC API is used in an incorrect fashion.
1928 newtype GhcApiError = GhcApiError String
1929
1930 instance Show GhcApiError where
1931 show (GhcApiError msg) = msg
1932
1933 instance Exception GhcApiError
1934
1935 mkApiErr :: DynFlags -> SDoc -> GhcApiError
1936 mkApiErr dflags msg = GhcApiError (showSDoc dflags msg)