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)