{-# LANGUAGE CPP, NondecreasingIndentation, ScopedTypeVariables #-}
{-# LANGUAGE TupleSections, NamedFieldPuns #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TypeFamilies #-}

-- -----------------------------------------------------------------------------
--
-- (c) The University of Glasgow, 2005-2012
--
-- The GHC API
--
-- -----------------------------------------------------------------------------

module GHC (
        -- * Initialisation
        defaultErrorHandler,
        defaultCleanupHandler,
        prettyPrintGhcErrors,
        withSignalHandlers,
        withCleanupSession,

        -- * GHC Monad
        Ghc, GhcT, GhcMonad(..), HscEnv,
        runGhc, runGhcT, initGhcMonad,
        printException,
        handleSourceError,
        needsTemplateHaskellOrQQ,

        -- * Flags and settings
        DynFlags(..), GeneralFlag(..), Severity(..), Backend(..), gopt,
        GhcMode(..), GhcLink(..),
        parseDynamicFlags, parseTargetFiles,
        getSessionDynFlags, setSessionDynFlags,
        getProgramDynFlags, setProgramDynFlags,
        getInteractiveDynFlags, setInteractiveDynFlags,
        interpretPackageEnv,

        -- * Logging
        Logger, getLogger,
        pushLogHook, popLogHook,
        pushLogHookM, popLogHookM, modifyLogger,
        putMsgM, putLogMsgM,


        -- * Targets
        Target(..), TargetId(..), Phase,
        setTargets,
        getTargets,
        addTarget,
        removeTarget,
        guessTarget,

        -- * Loading\/compiling the program
        depanal, depanalE,
        load, LoadHowMuch(..), InteractiveImport(..),
        SuccessFlag(..), succeeded, failed,
        defaultWarnErrLogger, WarnErrLogger,
        workingDirectoryChanged,
        parseModule, typecheckModule, desugarModule, loadModule,
        ParsedModule(..), TypecheckedModule(..), DesugaredModule(..),
        TypecheckedSource, ParsedSource, RenamedSource,   -- ditto
        TypecheckedMod, ParsedMod,
        moduleInfo, renamedSource, typecheckedSource,
        parsedSource, coreModule,

        -- ** Compiling to Core
        CoreModule(..),
        compileToCoreModule, compileToCoreSimplified,

        -- * Inspecting the module structure of the program
        ModuleGraph, emptyMG, mapMG, mkModuleGraph, mgModSummaries,
        mgLookupModule,
        ModSummary(..), ms_mod_name, ModLocation(..),
        getModSummary,
        getModuleGraph,
        isLoaded,
        topSortModuleGraph,

        -- * Inspecting modules
        ModuleInfo,
        getModuleInfo,
        modInfoTyThings,
        modInfoTopLevelScope,
        modInfoExports,
        modInfoExportsWithSelectors,
        modInfoInstances,
        modInfoIsExportedName,
        modInfoLookupName,
        modInfoIface,
        modInfoRdrEnv,
        modInfoSafe,
        lookupGlobalName,
        findGlobalAnns,
        mkPrintUnqualifiedForModule,
        ModIface, ModIface_(..),
        SafeHaskellMode(..),

        -- * Querying the environment
        -- packageDbModules,

        -- * Printing
        PrintUnqualified, alwaysQualify,

        -- * Interactive evaluation

        -- ** Executing statements
        execStmt, execStmt', ExecOptions(..), execOptions, ExecResult(..),
        resumeExec,

        -- ** Adding new declarations
        runDecls, runDeclsWithLocation, runParsedDecls,

        -- ** Get/set the current context
        parseImportDecl,
        setContext, getContext,
        setGHCiMonad, getGHCiMonad,

        -- ** Inspecting the current context
        getBindings, getInsts, getPrintUnqual,
        findModule, lookupModule,
        isModuleTrusted, moduleTrustReqs,
        getNamesInScope,
        getRdrNamesInScope,
        getGRE,
        moduleIsInterpreted,
        getInfo,
        showModule,
        moduleIsBootOrNotObjectLinkable,
        getNameToInstancesIndex,

        -- ** Inspecting types and kinds
        exprType, TcRnExprMode(..),
        typeKind,

        -- ** Looking up a Name
        parseName,
        lookupName,

        -- ** Compiling expressions
        HValue, parseExpr, compileParsedExpr,
        GHC.Runtime.Eval.compileExpr, dynCompileExpr,
        ForeignHValue,
        compileExprRemote, compileParsedExprRemote,

        -- ** Docs
        getDocs, GetDocsFailure(..),

        -- ** Other
        runTcInteractive,   -- Desired by some clients (#8878)
        isStmt, hasImport, isImport, isDecl,

        -- ** The debugger
        SingleStep(..),
        Resume(..),
        History(historyBreakInfo, historyEnclosingDecls),
        GHC.getHistorySpan, getHistoryModule,
        abandon, abandonAll,
        getResumeContext,
        GHC.obtainTermFromId, GHC.obtainTermFromVal, reconstructType,
        modInfoModBreaks,
        ModBreaks(..), BreakIndex,
        BreakInfo(..),
        GHC.Runtime.Eval.back,
        GHC.Runtime.Eval.forward,
        GHC.Runtime.Eval.setupBreakpoint,

        -- * Abstract syntax elements

        -- ** Units
        Unit,

        -- ** Modules
        Module, mkModule, pprModule, moduleName, moduleUnit,
        ModuleName, mkModuleName, moduleNameString,

        -- ** Names
        Name,
        isExternalName, nameModule, pprParenSymName, nameSrcSpan,
        NamedThing(..),
        RdrName(Qual,Unqual),

        -- ** Identifiers
        Id, idType,
        isImplicitId, isDeadBinder,
        isExportedId, isLocalId, isGlobalId,
        isRecordSelector,
        isPrimOpId, isFCallId, isClassOpId_maybe,
        isDataConWorkId, idDataCon,
        isDeadEndId, isDictonaryId,
        recordSelectorTyCon,

        -- ** Type constructors
        TyCon,
        tyConTyVars, tyConDataCons, tyConArity,
        isClassTyCon, isTypeSynonymTyCon, isTypeFamilyTyCon, isNewTyCon,
        isPrimTyCon, isFunTyCon,
        isFamilyTyCon, isOpenFamilyTyCon, isOpenTypeFamilyTyCon,
        tyConClass_maybe,
        synTyConRhs_maybe, synTyConDefn_maybe, tyConKind,

        -- ** Type variables
        TyVar,
        alphaTyVars,

        -- ** Data constructors
        DataCon,
        dataConType, dataConTyCon, dataConFieldLabels,
        dataConIsInfix, isVanillaDataCon, dataConWrapperType,
        dataConSrcBangs,
        StrictnessMark(..), isMarkedStrict,

        -- ** Classes
        Class,
        classMethods, classSCTheta, classTvsFds, classATs,
        pprFundeps,

        -- ** Instances
        ClsInst,
        instanceDFunId,
        pprInstance, pprInstanceHdr,
        pprFamInst,

        FamInst,

        -- ** Types and Kinds
        Type, splitForAllTyCoVars, funResultTy,
        pprParendType, pprTypeApp,
        Kind,
        PredType,
        ThetaType, pprForAll, pprThetaArrowTy,
        parseInstanceHead,
        getInstancesForType,

        -- ** Entities
        TyThing(..),

        -- ** Syntax
        module GHC.Hs, -- ToDo: remove extraneous bits

        -- ** Fixities
        FixityDirection(..),
        defaultFixity, maxPrecedence,
        negateFixity,
        compareFixity,
        LexicalFixity(..),

        -- ** Source locations
        SrcLoc(..), RealSrcLoc,
        mkSrcLoc, noSrcLoc,
        srcLocFile, srcLocLine, srcLocCol,
        SrcSpan(..), RealSrcSpan,
        mkSrcSpan, srcLocSpan, isGoodSrcSpan, noSrcSpan,
        srcSpanStart, srcSpanEnd,
        srcSpanFile,
        srcSpanStartLine, srcSpanEndLine,
        srcSpanStartCol, srcSpanEndCol,

        -- ** Located
        GenLocated(..), Located, RealLocated,

        -- *** Constructing Located
        noLoc, mkGeneralLocated,

        -- *** Deconstructing Located
        getLoc, unLoc,
        getRealSrcSpan, unRealSrcSpan,

        -- *** Combining and comparing Located values
        eqLocated, cmpLocated, combineLocs, addCLoc,
        leftmost_smallest, leftmost_largest, rightmost_smallest,
        spans, isSubspanOf,

        -- * Exceptions
        GhcException(..), showGhcException,
        GhcApiError(..),

        -- * Token stream manipulations
        Token,
        getTokenStream, getRichTokenStream,
        showRichTokenStream, addSourceToTokens,

        -- * Pure interface to the parser
        parser,

        -- * API Annotations
        AnnKeywordId(..),EpaComment(..),

        -- * Miscellaneous
        --sessionHscEnv,
        cyclicModuleErr,
  ) where

{-
 ToDo:

  * inline bits of GHC.Driver.Main here to simplify layering: hscTcExpr, hscStmt.
-}

#include "HsVersions.h"

import GHC.Prelude hiding (init)

import GHC.Platform
import GHC.Platform.Ways

import GHC.Driver.Phases   ( Phase(..), isHaskellSrcFilename
                           , isSourceFilename, startPhase )
import GHC.Driver.Env
import GHC.Driver.Errors
import GHC.Driver.CmdLine
import GHC.Driver.Session hiding (WarnReason(..))
import GHC.Driver.Backend
import GHC.Driver.Config
import GHC.Driver.Main
import GHC.Driver.Make
import GHC.Driver.Hooks
import GHC.Driver.Pipeline   ( compileOne' )
import GHC.Driver.Monad
import GHC.Driver.Ppr

import GHC.ByteCode.Types
import qualified GHC.Linker.Loader as Loader
import GHC.Runtime.Loader
import GHC.Runtime.Eval
import GHC.Runtime.Eval.Types
import GHC.Runtime.Interpreter
import GHC.Runtime.Context
import GHCi.RemoteTypes

import qualified GHC.Parser as Parser
import GHC.Parser.Lexer
import GHC.Parser.Annotation
import GHC.Parser.Errors.Ppr
import GHC.Parser.Utils

import GHC.Iface.Load        ( loadSysInterface )
import GHC.Hs
import GHC.Builtin.Types.Prim ( alphaTyVars )
import GHC.Iface.Tidy
import GHC.Data.Bag        ( listToBag )
import GHC.Data.StringBuffer
import GHC.Data.FastString
import qualified GHC.LanguageExtensions as LangExt

import GHC.Tc.Utils.Monad    ( finalSafeMode, fixSafeInstances, initIfaceTcRn )
import GHC.Tc.Types
import GHC.Tc.Utils.TcType
import GHC.Tc.Module
import GHC.Tc.Utils.Instantiate
import GHC.Tc.Instance.Family

import GHC.Utils.TmpFs
import GHC.SysTools
import GHC.SysTools.BaseDir

import GHC.Utils.Error
import GHC.Utils.Monad
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Logger

import GHC.Core.Predicate
import GHC.Core.Type  hiding( typeKind )
import GHC.Core.TyCon
import GHC.Core.TyCo.Ppr   ( pprForAll )
import GHC.Core.Class
import GHC.Core.DataCon
import GHC.Core.FVs        ( orphNamesOfFamInst )
import GHC.Core.FamInstEnv ( FamInst, famInstEnvElts )
import GHC.Core.InstEnv
import GHC.Core

import GHC.Types.Id
import GHC.Types.Name      hiding ( varName )
import GHC.Types.Avail
import GHC.Types.SrcLoc
import GHC.Types.TyThing.Ppr  ( pprFamInst )
import GHC.Types.Annotations
import GHC.Types.Name.Set
import GHC.Types.Name.Reader
import GHC.Types.SourceError
import GHC.Types.SafeHaskell
import GHC.Types.Fixity
import GHC.Types.Target
import GHC.Types.Basic
import GHC.Types.TyThing
import GHC.Types.Name.Env
import GHC.Types.Name.Ppr
import GHC.Types.TypeEnv
import GHC.Types.SourceFile

import GHC.Unit
import GHC.Unit.Env
import GHC.Unit.External
import GHC.Unit.State
import GHC.Unit.Finder
import GHC.Unit.Module.ModIface
import GHC.Unit.Module.ModGuts
import GHC.Unit.Module.ModDetails
import GHC.Unit.Module.ModSummary
import GHC.Unit.Module.Graph
import GHC.Unit.Home.ModInfo

import Data.Foldable
import qualified Data.Map.Strict as Map
import Data.Set (Set)
import qualified Data.Set as S
import qualified Data.Sequence as Seq
import Data.Maybe
import Data.Time
import Data.Typeable    ( Typeable )
import Data.Word        ( Word8 )
import Control.Monad
import System.Exit      ( exitWith, ExitCode(..) )
import GHC.Utils.Exception
import Data.IORef
import System.FilePath
import Control.Concurrent
import Control.Applicative ((<|>))
import Control.Monad.Catch as MC

import GHC.Data.Maybe
import System.IO.Error  ( isDoesNotExistError )
import System.Environment ( getEnv )
import System.Directory
import Data.List (isPrefixOf)


-- %************************************************************************
-- %*                                                                      *
--             Initialisation: exception handlers
-- %*                                                                      *
-- %************************************************************************


-- | Install some default exception handlers and run the inner computation.
-- Unless you want to handle exceptions yourself, you should wrap this around
-- the top level of your program.  The default handlers output the error
-- message(s) to stderr and exit cleanly.
defaultErrorHandler :: (ExceptionMonad m)
                    => FatalMessager -> FlushOut -> m a -> m a
defaultErrorHandler :: forall (m :: * -> *) a.
ExceptionMonad m =>
FatalMessager -> FlushOut -> m a -> m a
defaultErrorHandler FatalMessager
fm (FlushOut IO ()
flushOut) m a
inner =
  -- top-level exception handler: any unrecognised exception is a compiler bug.
  (SomeException -> m a) -> m a -> m a
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
MC.handle (\SomeException
exception -> IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ do
           IO ()
flushOut
           case SomeException -> Maybe IOError
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exception of
                -- an IO exception probably isn't our fault, so don't panic
                Just (IOError
ioe :: IOException) ->
                  FatalMessager -> FatalMessager
fatalErrorMsg'' FatalMessager
fm (IOError -> FilePath
forall a. Show a => a -> FilePath
show IOError
ioe)
                Maybe IOError
_ -> case SomeException -> Maybe AsyncException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exception of
                     Just AsyncException
UserInterrupt ->
                         -- Important to let this one propagate out so our
                         -- calling process knows we were interrupted by ^C
                         IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ AsyncException -> IO ()
forall e a. Exception e => e -> IO a
throwIO AsyncException
UserInterrupt
                     Just AsyncException
StackOverflow ->
                         FatalMessager -> FatalMessager
fatalErrorMsg'' FatalMessager
fm FilePath
"stack overflow: use +RTS -K<size> to increase it"
                     Maybe AsyncException
_ -> case SomeException -> Maybe ExitCode
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exception of
                          Just (ExitCode
ex :: ExitCode) -> IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ExitCode -> IO ()
forall e a. Exception e => e -> IO a
throwIO ExitCode
ex
                          Maybe ExitCode
_ ->
                              FatalMessager -> FatalMessager
fatalErrorMsg'' FatalMessager
fm
                                  (GhcException -> FilePath
forall a. Show a => a -> FilePath
show (FilePath -> GhcException
Panic (SomeException -> FilePath
forall a. Show a => a -> FilePath
show SomeException
exception)))
           ExitCode -> IO a
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
1)
         ) (m a -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$

  -- error messages propagated as exceptions
  (GhcException -> m a) -> m a -> m a
forall (m :: * -> *) a.
ExceptionMonad m =>
(GhcException -> m a) -> m a -> m a
handleGhcException
            (\GhcException
ge -> IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ do
                IO ()
flushOut
                case GhcException
ge of
                     Signal Int
_ -> ExitCode -> IO a
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
1)
                     GhcException
_ -> do FatalMessager -> FatalMessager
fatalErrorMsg'' FatalMessager
fm (GhcException -> FilePath
forall a. Show a => a -> FilePath
show GhcException
ge)
                             ExitCode -> IO a
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
1)
            ) (m a -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$
  m a
inner

-- | This function is no longer necessary, cleanup is now done by
-- runGhc/runGhcT.
{-# DEPRECATED defaultCleanupHandler "Cleanup is now done by runGhc/runGhcT" #-}
defaultCleanupHandler :: (ExceptionMonad m) => DynFlags -> m a -> m a
defaultCleanupHandler :: forall (m :: * -> *) a. ExceptionMonad m => DynFlags -> m a -> m a
defaultCleanupHandler DynFlags
_ m a
m = m a
m
 where _warning_suppression :: m a
_warning_suppression = m a
m m a -> m Any -> m a
forall (m :: * -> *) a b. MonadCatch m => m a -> m b -> m a
`MC.onException` m Any
forall a. HasCallStack => a
undefined


-- %************************************************************************
-- %*                                                                      *
--             The Ghc Monad
-- %*                                                                      *
-- %************************************************************************

-- | Run function for the 'Ghc' monad.
--
-- It initialises the GHC session and warnings via 'initGhcMonad'.  Each call
-- to this function will create a new session which should not be shared among
-- several threads.
--
-- Any errors not handled inside the 'Ghc' action are propagated as IO
-- exceptions.

runGhc :: Maybe FilePath  -- ^ See argument to 'initGhcMonad'.
       -> Ghc a           -- ^ The action to perform.
       -> IO a
runGhc :: forall a. Maybe FilePath -> Ghc a -> IO a
runGhc Maybe FilePath
mb_top_dir Ghc a
ghc = do
  IORef HscEnv
ref <- HscEnv -> IO (IORef HscEnv)
forall a. a -> IO (IORef a)
newIORef (FilePath -> HscEnv
forall a. FilePath -> a
panic FilePath
"empty session")
  let session :: Session
session = IORef HscEnv -> Session
Session IORef HscEnv
ref
  (Ghc a -> Session -> IO a) -> Session -> Ghc a -> IO a
forall a b c. (a -> b -> c) -> b -> a -> c
flip Ghc a -> Session -> IO a
forall a. Ghc a -> Session -> IO a
unGhc Session
session (Ghc a -> IO a) -> Ghc a -> IO a
forall a b. (a -> b) -> a -> b
$ Ghc a -> Ghc a
forall (m :: * -> *) a. ExceptionMonad m => m a -> m a
withSignalHandlers (Ghc a -> Ghc a) -> Ghc a -> Ghc a
forall a b. (a -> b) -> a -> b
$ do -- catch ^C
    Maybe FilePath -> Ghc ()
forall (m :: * -> *). GhcMonad m => Maybe FilePath -> m ()
initGhcMonad Maybe FilePath
mb_top_dir
    Ghc a -> Ghc a
forall (m :: * -> *) a. GhcMonad m => m a -> m a
withCleanupSession Ghc a
ghc

-- | Run function for 'GhcT' monad transformer.
--
-- It initialises the GHC session and warnings via 'initGhcMonad'.  Each call
-- to this function will create a new session which should not be shared among
-- several threads.

runGhcT :: ExceptionMonad m =>
           Maybe FilePath  -- ^ See argument to 'initGhcMonad'.
        -> GhcT m a        -- ^ The action to perform.
        -> m a
runGhcT :: forall (m :: * -> *) a.
ExceptionMonad m =>
Maybe FilePath -> GhcT m a -> m a
runGhcT Maybe FilePath
mb_top_dir GhcT m a
ghct = do
  IORef HscEnv
ref <- IO (IORef HscEnv) -> m (IORef HscEnv)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef HscEnv) -> m (IORef HscEnv))
-> IO (IORef HscEnv) -> m (IORef HscEnv)
forall a b. (a -> b) -> a -> b
$ HscEnv -> IO (IORef HscEnv)
forall a. a -> IO (IORef a)
newIORef (FilePath -> HscEnv
forall a. FilePath -> a
panic FilePath
"empty session")
  let session :: Session
session = IORef HscEnv -> Session
Session IORef HscEnv
ref
  (GhcT m a -> Session -> m a) -> Session -> GhcT m a -> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip GhcT m a -> Session -> m a
forall (m :: * -> *) a. GhcT m a -> Session -> m a
unGhcT Session
session (GhcT m a -> m a) -> GhcT m a -> m a
forall a b. (a -> b) -> a -> b
$ GhcT m a -> GhcT m a
forall (m :: * -> *) a. ExceptionMonad m => m a -> m a
withSignalHandlers (GhcT m a -> GhcT m a) -> GhcT m a -> GhcT m a
forall a b. (a -> b) -> a -> b
$ do -- catch ^C
    Maybe FilePath -> GhcT m ()
forall (m :: * -> *). GhcMonad m => Maybe FilePath -> m ()
initGhcMonad Maybe FilePath
mb_top_dir
    GhcT m a -> GhcT m a
forall (m :: * -> *) a. GhcMonad m => m a -> m a
withCleanupSession GhcT m a
ghct

withCleanupSession :: GhcMonad m => m a -> m a
withCleanupSession :: forall (m :: * -> *) a. GhcMonad m => m a -> m a
withCleanupSession m a
ghc = m a
ghc m a -> m () -> m a
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
`MC.finally` m ()
cleanup
  where
   cleanup :: m ()
cleanup = do
      HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
      let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
      let logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
      let tmpfs :: TmpFs
tmpfs  = HscEnv -> TmpFs
hsc_tmpfs HscEnv
hsc_env
      IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
          Logger -> TmpFs -> DynFlags -> IO ()
cleanTempFiles Logger
logger TmpFs
tmpfs DynFlags
dflags
          Logger -> TmpFs -> DynFlags -> IO ()
cleanTempDirs Logger
logger TmpFs
tmpfs DynFlags
dflags
          (Interp -> IO ()) -> Maybe Interp -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Interp -> IO ()
stopInterp (HscEnv -> Maybe Interp
hsc_interp HscEnv
hsc_env)
          --  exceptions will be blocked while we clean the temporary files,
          -- so there shouldn't be any difficulty if we receive further
          -- signals.

-- | Initialise a GHC session.
--
-- If you implement a custom 'GhcMonad' you must call this function in the
-- monad run function.  It will initialise the session variable and clear all
-- warnings.
--
-- The first argument should point to the directory where GHC's library files
-- reside.  More precisely, this should be the output of @ghc --print-libdir@
-- of the version of GHC the module using this API is compiled with.  For
-- portability, you should use the @ghc-paths@ package, available at
-- <http://hackage.haskell.org/package/ghc-paths>.

initGhcMonad :: GhcMonad m => Maybe FilePath -> m ()
initGhcMonad :: forall (m :: * -> *). GhcMonad m => Maybe FilePath -> m ()
initGhcMonad Maybe FilePath
mb_top_dir
  = do { HscEnv
env <- IO HscEnv -> m HscEnv
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO HscEnv -> m HscEnv) -> IO HscEnv -> m HscEnv
forall a b. (a -> b) -> a -> b
$
                do { FilePath
top_dir <- Maybe FilePath -> IO FilePath
findTopDir Maybe FilePath
mb_top_dir
                   ; Settings
mySettings <- FilePath -> IO Settings
initSysTools FilePath
top_dir
                   ; LlvmConfig
myLlvmConfig <- FilePath -> IO LlvmConfig
lazyInitLlvmConfig FilePath
top_dir
                   ; DynFlags
dflags <- DynFlags -> IO DynFlags
initDynFlags (Settings -> LlvmConfig -> DynFlags
defaultDynFlags Settings
mySettings LlvmConfig
myLlvmConfig)
                   ; HscEnv
hsc_env <- DynFlags -> IO HscEnv
newHscEnv DynFlags
dflags
                   ; Logger -> DynFlags -> IO ()
forall (m :: * -> *). MonadIO m => Logger -> DynFlags -> m ()
checkBrokenTablesNextToCode (HscEnv -> Logger
hsc_logger HscEnv
hsc_env) DynFlags
dflags
                   ; DynFlags -> IO ()
setUnsafeGlobalDynFlags DynFlags
dflags
                      -- c.f. DynFlags.parseDynamicFlagsFull, which
                      -- creates DynFlags and sets the UnsafeGlobalDynFlags
                   ; HscEnv -> IO HscEnv
forall (m :: * -> *) a. Monad m => a -> m a
return HscEnv
hsc_env }
       ; HscEnv -> m ()
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
env }

-- | The binutils linker on ARM emits unnecessary R_ARM_COPY relocations which
-- breaks tables-next-to-code in dynamically linked modules. This
-- check should be more selective but there is currently no released
-- version where this bug is fixed.
-- See https://sourceware.org/bugzilla/show_bug.cgi?id=16177 and
-- https://gitlab.haskell.org/ghc/ghc/issues/4210#note_78333
checkBrokenTablesNextToCode :: MonadIO m => Logger -> DynFlags -> m ()
checkBrokenTablesNextToCode :: forall (m :: * -> *). MonadIO m => Logger -> DynFlags -> m ()
checkBrokenTablesNextToCode Logger
logger DynFlags
dflags
  = do { Bool
broken <- Logger -> DynFlags -> m Bool
forall (m :: * -> *). MonadIO m => Logger -> DynFlags -> m Bool
checkBrokenTablesNextToCode' Logger
logger DynFlags
dflags
       ; Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
broken
         (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do { Any
_ <- IO Any -> m Any
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Any -> m Any) -> IO Any -> m Any
forall a b. (a -> b) -> a -> b
$ GhcApiError -> IO Any
forall e a. Exception e => e -> IO a
throwIO (GhcApiError -> IO Any) -> GhcApiError -> IO Any
forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> GhcApiError
mkApiErr DynFlags
dflags SDoc
invalidLdErr
              ; IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ FatalMessager
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"unsupported linker"
              }
       }
  where
    invalidLdErr :: SDoc
invalidLdErr = FilePath -> SDoc
text FilePath
"Tables-next-to-code not supported on ARM" SDoc -> SDoc -> SDoc
<+>
                   FilePath -> SDoc
text FilePath
"when using binutils ld (please see:" SDoc -> SDoc -> SDoc
<+>
                   FilePath -> SDoc
text FilePath
"https://sourceware.org/bugzilla/show_bug.cgi?id=16177)"

checkBrokenTablesNextToCode' :: MonadIO m => Logger -> DynFlags -> m Bool
checkBrokenTablesNextToCode' :: forall (m :: * -> *). MonadIO m => Logger -> DynFlags -> m Bool
checkBrokenTablesNextToCode' Logger
logger DynFlags
dflags
  | Bool -> Bool
not (Arch -> Bool
isARM Arch
arch)                 = Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  | Way
WayDyn Way -> Set Way -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.notMember` DynFlags -> Set Way
ways DynFlags
dflags = Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  | Bool -> Bool
not Bool
tablesNextToCode             = Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  | Bool
otherwise                        = do
    LinkerInfo
linkerInfo <- IO LinkerInfo -> m LinkerInfo
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO LinkerInfo -> m LinkerInfo) -> IO LinkerInfo -> m LinkerInfo
forall a b. (a -> b) -> a -> b
$ Logger -> DynFlags -> IO LinkerInfo
getLinkerInfo Logger
logger DynFlags
dflags
    case LinkerInfo
linkerInfo of
      GnuLD [Option]
_  -> Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
      LinkerInfo
_        -> Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  where platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
        arch :: Arch
arch = Platform -> Arch
platformArch Platform
platform
        tablesNextToCode :: Bool
tablesNextToCode = Platform -> Bool
platformTablesNextToCode Platform
platform


-- %************************************************************************
-- %*                                                                      *
--             Flags & settings
-- %*                                                                      *
-- %************************************************************************

-- $DynFlags
--
-- The GHC session maintains two sets of 'DynFlags':
--
--   * The "interactive" @DynFlags@, which are used for everything
--     related to interactive evaluation, including 'runStmt',
--     'runDecls', 'exprType', 'lookupName' and so on (everything
--     under \"Interactive evaluation\" in this module).
--
--   * The "program" @DynFlags@, which are used when loading
--     whole modules with 'load'
--
-- 'setInteractiveDynFlags', 'getInteractiveDynFlags' work with the
-- interactive @DynFlags@.
--
-- 'setProgramDynFlags', 'getProgramDynFlags' work with the
-- program @DynFlags@.
--
-- 'setSessionDynFlags' sets both @DynFlags@, and 'getSessionDynFlags'
-- retrieves the program @DynFlags@ (for backwards compatibility).


-- | Updates both the interactive and program DynFlags in a Session.
-- This also reads the package database (unless it has already been
-- read), and prepares the compilers knowledge about packages.  It can
-- be called again to load new packages: just add new package flags to
-- (packageFlags dflags).
setSessionDynFlags :: GhcMonad m => DynFlags -> m ()
setSessionDynFlags :: forall (m :: * -> *). GhcMonad m => DynFlags -> m ()
setSessionDynFlags DynFlags
dflags0 = do
  Logger
logger <- m Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
  DynFlags
dflags1 <- Logger -> DynFlags -> m DynFlags
forall (m :: * -> *). MonadIO m => Logger -> DynFlags -> m DynFlags
checkNewDynFlags Logger
logger DynFlags
dflags0
  HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
  let cached_unit_dbs :: Maybe [UnitDatabase UnitId]
cached_unit_dbs = HscEnv -> Maybe [UnitDatabase UnitId]
hsc_unit_dbs HscEnv
hsc_env
  ([UnitDatabase UnitId]
dbs,UnitState
unit_state,HomeUnit
home_unit,Maybe PlatformConstants
mconstants) <- IO
  ([UnitDatabase UnitId], UnitState, HomeUnit,
   Maybe PlatformConstants)
-> m ([UnitDatabase UnitId], UnitState, HomeUnit,
      Maybe PlatformConstants)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO
   ([UnitDatabase UnitId], UnitState, HomeUnit,
    Maybe PlatformConstants)
 -> m ([UnitDatabase UnitId], UnitState, HomeUnit,
       Maybe PlatformConstants))
-> IO
     ([UnitDatabase UnitId], UnitState, HomeUnit,
      Maybe PlatformConstants)
-> m ([UnitDatabase UnitId], UnitState, HomeUnit,
      Maybe PlatformConstants)
forall a b. (a -> b) -> a -> b
$ Logger
-> DynFlags
-> Maybe [UnitDatabase UnitId]
-> IO
     ([UnitDatabase UnitId], UnitState, HomeUnit,
      Maybe PlatformConstants)
initUnits Logger
logger DynFlags
dflags1 Maybe [UnitDatabase UnitId]
cached_unit_dbs

  DynFlags
dflags <- IO DynFlags -> m DynFlags
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO DynFlags -> m DynFlags) -> IO DynFlags -> m DynFlags
forall a b. (a -> b) -> a -> b
$ DynFlags -> Maybe PlatformConstants -> IO DynFlags
updatePlatformConstants DynFlags
dflags1 Maybe PlatformConstants
mconstants

  -- Interpreter
  Maybe Interp
interp <- if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ExternalInterpreter DynFlags
dflags
    then do
         let
           prog :: FilePath
prog = DynFlags -> FilePath
pgm_i DynFlags
dflags FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
flavour
           profiled :: Bool
profiled = DynFlags -> Set Way
ways DynFlags
dflags Set Way -> Way -> Bool
`hasWay` Way
WayProf
           dynamic :: Bool
dynamic  = DynFlags -> Set Way
ways DynFlags
dflags Set Way -> Way -> Bool
`hasWay` Way
WayDyn
           flavour :: FilePath
flavour
             | Bool
profiled  = FilePath
"-prof" -- FIXME: can't we have both?
             | Bool
dynamic   = FilePath
"-dyn"
             | Bool
otherwise = FilePath
""
           msg :: SDoc
msg = FilePath -> SDoc
text FilePath
"Starting " SDoc -> SDoc -> SDoc
<> FilePath -> SDoc
text FilePath
prog
         IO ()
tr <- if DynFlags -> Int
verbosity DynFlags
dflags Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
3
                then IO () -> m (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Logger -> DynFlags -> SDoc -> IO ()
logInfo Logger
logger DynFlags
dflags (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
defaultDumpStyle SDoc
msg)
                else IO () -> m (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
         let
          conf :: IServConfig
conf = IServConfig
            { iservConfProgram :: FilePath
iservConfProgram  = FilePath
prog
            , iservConfOpts :: [FilePath]
iservConfOpts     = DynFlags -> (DynFlags -> [FilePath]) -> [FilePath]
forall a. DynFlags -> (DynFlags -> [a]) -> [a]
getOpts DynFlags
dflags DynFlags -> [FilePath]
opt_i
            , iservConfProfiled :: Bool
iservConfProfiled = Bool
profiled
            , iservConfDynamic :: Bool
iservConfDynamic  = Bool
dynamic
            , iservConfHook :: Maybe (CreateProcess -> IO ProcessHandle)
iservConfHook     = Hooks -> Maybe (CreateProcess -> IO ProcessHandle)
createIservProcessHook (HscEnv -> Hooks
hsc_hooks HscEnv
hsc_env)
            , iservConfTrace :: IO ()
iservConfTrace    = IO ()
tr
            }
         MVar IServState
s <- IO (MVar IServState) -> m (MVar IServState)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (MVar IServState) -> m (MVar IServState))
-> IO (MVar IServState) -> m (MVar IServState)
forall a b. (a -> b) -> a -> b
$ IServState -> IO (MVar IServState)
forall a. a -> IO (MVar a)
newMVar IServState
IServPending
         Loader
loader <- IO Loader -> m Loader
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Loader
Loader.uninitializedLoader
         Maybe Interp -> m (Maybe Interp)
forall (m :: * -> *) a. Monad m => a -> m a
return (Interp -> Maybe Interp
forall a. a -> Maybe a
Just (InterpInstance -> Loader -> Interp
Interp (IServConfig -> IServ -> InterpInstance
ExternalInterp IServConfig
conf (MVar IServState -> IServ
IServ MVar IServState
s)) Loader
loader))
    else
#if defined(HAVE_INTERNAL_INTERPRETER)
     do
      Loader
loader <- IO Loader -> m Loader
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Loader
Loader.uninitializedLoader
      Maybe Interp -> m (Maybe Interp)
forall (m :: * -> *) a. Monad m => a -> m a
return (Interp -> Maybe Interp
forall a. a -> Maybe a
Just (InterpInstance -> Loader -> Interp
Interp InterpInstance
InternalInterp Loader
loader))
#else
      return Nothing
#endif

  let unit_env :: UnitEnv
unit_env = UnitEnv
        { ue_platform :: Platform
ue_platform  = DynFlags -> Platform
targetPlatform DynFlags
dflags
        , ue_namever :: GhcNameVersion
ue_namever   = DynFlags -> GhcNameVersion
ghcNameVersion DynFlags
dflags
        , ue_home_unit :: HomeUnit
ue_home_unit = HomeUnit
home_unit
        , ue_units :: UnitState
ue_units     = UnitState
unit_state
        }
  (HscEnv -> HscEnv) -> m ()
forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession ((HscEnv -> HscEnv) -> m ()) -> (HscEnv -> HscEnv) -> m ()
forall a b. (a -> b) -> a -> b
$ \HscEnv
h -> HscEnv
h{ hsc_dflags :: DynFlags
hsc_dflags = DynFlags
dflags
                         , hsc_IC :: InteractiveContext
hsc_IC = (HscEnv -> InteractiveContext
hsc_IC HscEnv
h){ ic_dflags :: DynFlags
ic_dflags = DynFlags
dflags }
                         , hsc_interp :: Maybe Interp
hsc_interp = HscEnv -> Maybe Interp
hsc_interp HscEnv
h Maybe Interp -> Maybe Interp -> Maybe Interp
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Interp
interp
                           -- we only update the interpreter if there wasn't
                           -- already one set up
                         , hsc_unit_env :: UnitEnv
hsc_unit_env = UnitEnv
unit_env
                         , hsc_unit_dbs :: Maybe [UnitDatabase UnitId]
hsc_unit_dbs = [UnitDatabase UnitId] -> Maybe [UnitDatabase UnitId]
forall a. a -> Maybe a
Just [UnitDatabase UnitId]
dbs
                         }
  m ()
forall (m :: * -> *). GhcMonad m => m ()
invalidateModSummaryCache

-- | Sets the program 'DynFlags'.  Note: this invalidates the internal
-- cached module graph, causing more work to be done the next time
-- 'load' is called.
--
-- Returns a boolean indicating if preload units have changed and need to be
-- reloaded.
setProgramDynFlags :: GhcMonad m => DynFlags -> m Bool
setProgramDynFlags :: forall (m :: * -> *). GhcMonad m => DynFlags -> m Bool
setProgramDynFlags DynFlags
dflags = Bool -> DynFlags -> m Bool
forall (m :: * -> *). GhcMonad m => Bool -> DynFlags -> m Bool
setProgramDynFlags_ Bool
True DynFlags
dflags

setProgramDynFlags_ :: GhcMonad m => Bool -> DynFlags -> m Bool
setProgramDynFlags_ :: forall (m :: * -> *). GhcMonad m => Bool -> DynFlags -> m Bool
setProgramDynFlags_ Bool
invalidate_needed DynFlags
dflags = do
  Logger
logger <- m Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
  DynFlags
dflags0 <- Logger -> DynFlags -> m DynFlags
forall (m :: * -> *). MonadIO m => Logger -> DynFlags -> m DynFlags
checkNewDynFlags Logger
logger DynFlags
dflags
  DynFlags
dflags_prev <- m DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getProgramDynFlags
  let changed :: Bool
changed = DynFlags -> DynFlags -> Bool
packageFlagsChanged DynFlags
dflags_prev DynFlags
dflags0
  if Bool
changed
    then do
        HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
        let cached_unit_dbs :: Maybe [UnitDatabase UnitId]
cached_unit_dbs = HscEnv -> Maybe [UnitDatabase UnitId]
hsc_unit_dbs HscEnv
hsc_env
        ([UnitDatabase UnitId]
dbs,UnitState
unit_state,HomeUnit
home_unit,Maybe PlatformConstants
mconstants) <- IO
  ([UnitDatabase UnitId], UnitState, HomeUnit,
   Maybe PlatformConstants)
-> m ([UnitDatabase UnitId], UnitState, HomeUnit,
      Maybe PlatformConstants)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO
   ([UnitDatabase UnitId], UnitState, HomeUnit,
    Maybe PlatformConstants)
 -> m ([UnitDatabase UnitId], UnitState, HomeUnit,
       Maybe PlatformConstants))
-> IO
     ([UnitDatabase UnitId], UnitState, HomeUnit,
      Maybe PlatformConstants)
-> m ([UnitDatabase UnitId], UnitState, HomeUnit,
      Maybe PlatformConstants)
forall a b. (a -> b) -> a -> b
$ Logger
-> DynFlags
-> Maybe [UnitDatabase UnitId]
-> IO
     ([UnitDatabase UnitId], UnitState, HomeUnit,
      Maybe PlatformConstants)
initUnits Logger
logger DynFlags
dflags0 Maybe [UnitDatabase UnitId]
cached_unit_dbs

        DynFlags
dflags1 <- IO DynFlags -> m DynFlags
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO DynFlags -> m DynFlags) -> IO DynFlags -> m DynFlags
forall a b. (a -> b) -> a -> b
$ DynFlags -> Maybe PlatformConstants -> IO DynFlags
updatePlatformConstants DynFlags
dflags0 Maybe PlatformConstants
mconstants

        let unit_env :: UnitEnv
unit_env = UnitEnv
              { ue_platform :: Platform
ue_platform  = DynFlags -> Platform
targetPlatform DynFlags
dflags1
              , ue_namever :: GhcNameVersion
ue_namever   = DynFlags -> GhcNameVersion
ghcNameVersion DynFlags
dflags1
              , ue_home_unit :: HomeUnit
ue_home_unit = HomeUnit
home_unit
              , ue_units :: UnitState
ue_units     = UnitState
unit_state
              }
        (HscEnv -> HscEnv) -> m ()
forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession ((HscEnv -> HscEnv) -> m ()) -> (HscEnv -> HscEnv) -> m ()
forall a b. (a -> b) -> a -> b
$ \HscEnv
h -> HscEnv
h{ hsc_dflags :: DynFlags
hsc_dflags   = DynFlags
dflags1
                               , hsc_unit_dbs :: Maybe [UnitDatabase UnitId]
hsc_unit_dbs = [UnitDatabase UnitId] -> Maybe [UnitDatabase UnitId]
forall a. a -> Maybe a
Just [UnitDatabase UnitId]
dbs
                               , hsc_unit_env :: UnitEnv
hsc_unit_env = UnitEnv
unit_env
                               }
    else (HscEnv -> HscEnv) -> m ()
forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession ((HscEnv -> HscEnv) -> m ()) -> (HscEnv -> HscEnv) -> m ()
forall a b. (a -> b) -> a -> b
$ \HscEnv
h -> HscEnv
h{ hsc_dflags :: DynFlags
hsc_dflags = DynFlags
dflags0 }
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
invalidate_needed (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ m ()
forall (m :: * -> *). GhcMonad m => m ()
invalidateModSummaryCache
  Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
changed


-- When changing the DynFlags, we want the changes to apply to future
-- loads, but without completely discarding the program.  But the
-- DynFlags are cached in each ModSummary in the hsc_mod_graph, so
-- after a change to DynFlags, the changes would apply to new modules
-- but not existing modules; this seems undesirable.
--
-- Furthermore, the GHC API client might expect that changing
-- log_action would affect future compilation messages, but for those
-- modules we have cached ModSummaries for, we'll continue to use the
-- old log_action.  This is definitely wrong (#7478).
--
-- Hence, we invalidate the ModSummary cache after changing the
-- DynFlags.  We do this by tweaking the date on each ModSummary, so
-- that the next downsweep will think that all the files have changed
-- and preprocess them again.  This won't necessarily cause everything
-- to be recompiled, because by the time we check whether we need to
-- recompile a module, we'll have re-summarised the module and have a
-- correct ModSummary.
--
invalidateModSummaryCache :: GhcMonad m => m ()
invalidateModSummaryCache :: forall (m :: * -> *). GhcMonad m => m ()
invalidateModSummaryCache =
  (HscEnv -> HscEnv) -> m ()
forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession ((HscEnv -> HscEnv) -> m ()) -> (HscEnv -> HscEnv) -> m ()
forall a b. (a -> b) -> a -> b
$ \HscEnv
h -> HscEnv
h { hsc_mod_graph :: ModuleGraph
hsc_mod_graph = (ModSummary -> ModSummary) -> ModuleGraph -> ModuleGraph
mapMG ModSummary -> ModSummary
inval (HscEnv -> ModuleGraph
hsc_mod_graph HscEnv
h) }
 where
  inval :: ModSummary -> ModSummary
inval ModSummary
ms = ModSummary
ms { ms_hs_date :: UTCTime
ms_hs_date = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (-NominalDiffTime
1) (ModSummary -> UTCTime
ms_hs_date ModSummary
ms) }

-- | Returns the program 'DynFlags'.
getProgramDynFlags :: GhcMonad m => m DynFlags
getProgramDynFlags :: forall (m :: * -> *). GhcMonad m => m DynFlags
getProgramDynFlags = m DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags

-- | Set the 'DynFlags' used to evaluate interactive expressions.
-- Also initialise (load) plugins.
--
-- Note: this cannot be used for changes to packages.  Use
-- 'setSessionDynFlags', or 'setProgramDynFlags' and then copy the
-- 'unitState' into the interactive @DynFlags@.
setInteractiveDynFlags :: GhcMonad m => DynFlags -> m ()
setInteractiveDynFlags :: forall (m :: * -> *). GhcMonad m => DynFlags -> m ()
setInteractiveDynFlags DynFlags
dflags = do
  Logger
logger <- m Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
  DynFlags
dflags' <- Logger -> DynFlags -> m DynFlags
forall (m :: * -> *). MonadIO m => Logger -> DynFlags -> m DynFlags
checkNewDynFlags Logger
logger DynFlags
dflags
  DynFlags
dflags'' <- Logger -> DynFlags -> m DynFlags
forall (m :: * -> *). MonadIO m => Logger -> DynFlags -> m DynFlags
checkNewInteractiveDynFlags Logger
logger DynFlags
dflags'
  (HscEnv -> m HscEnv) -> m ()
forall (m :: * -> *). GhcMonad m => (HscEnv -> m HscEnv) -> m ()
modifySessionM ((HscEnv -> m HscEnv) -> m ()) -> (HscEnv -> m HscEnv) -> m ()
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env0 -> do
    let ic0 :: InteractiveContext
ic0 = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env0

    -- Initialise (load) plugins in the interactive environment with the new
    -- DynFlags
    HscEnv
plugin_env <- IO HscEnv -> m HscEnv
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO HscEnv -> m HscEnv) -> IO HscEnv -> m HscEnv
forall a b. (a -> b) -> a -> b
$ HscEnv -> IO HscEnv
initializePlugins (HscEnv -> IO HscEnv) -> HscEnv -> IO HscEnv
forall a b. (a -> b) -> a -> b
$ HscEnv -> HscEnv
mkInteractiveHscEnv (HscEnv -> HscEnv) -> HscEnv -> HscEnv
forall a b. (a -> b) -> a -> b
$
                    HscEnv
hsc_env0 { hsc_IC :: InteractiveContext
hsc_IC = InteractiveContext
ic0 { ic_dflags :: DynFlags
ic_dflags = DynFlags
dflags'' }}

    -- Update both plugins cache and DynFlags in the interactive context.
    HscEnv -> m HscEnv
forall (m :: * -> *) a. Monad m => a -> m a
return (HscEnv -> m HscEnv) -> HscEnv -> m HscEnv
forall a b. (a -> b) -> a -> b
$ HscEnv
hsc_env0
                { hsc_IC :: InteractiveContext
hsc_IC = InteractiveContext
ic0
                    { ic_plugins :: [LoadedPlugin]
ic_plugins = HscEnv -> [LoadedPlugin]
hsc_plugins HscEnv
plugin_env
                    , ic_dflags :: DynFlags
ic_dflags  = HscEnv -> DynFlags
hsc_dflags  HscEnv
plugin_env
                    }
                }


-- | Get the 'DynFlags' used to evaluate interactive expressions.
getInteractiveDynFlags :: GhcMonad m => m DynFlags
getInteractiveDynFlags :: forall (m :: * -> *). GhcMonad m => m DynFlags
getInteractiveDynFlags = (HscEnv -> m DynFlags) -> m DynFlags
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m DynFlags) -> m DynFlags)
-> (HscEnv -> m DynFlags) -> m DynFlags
forall a b. (a -> b) -> a -> b
$ \HscEnv
h -> DynFlags -> m DynFlags
forall (m :: * -> *) a. Monad m => a -> m a
return (InteractiveContext -> DynFlags
ic_dflags (HscEnv -> InteractiveContext
hsc_IC HscEnv
h))


parseDynamicFlags
    :: MonadIO m
    => Logger
    -> DynFlags
    -> [Located String]
    -> m (DynFlags, [Located String], [Warn])
parseDynamicFlags :: forall (m :: * -> *).
MonadIO m =>
Logger
-> DynFlags
-> [Located FilePath]
-> m (DynFlags, [Located FilePath], [Warn])
parseDynamicFlags Logger
logger DynFlags
dflags [Located FilePath]
cmdline = do
  (DynFlags
dflags1, [Located FilePath]
leftovers, [Warn]
warns) <- DynFlags
-> [Located FilePath] -> m (DynFlags, [Located FilePath], [Warn])
forall (m :: * -> *).
MonadIO m =>
DynFlags
-> [Located FilePath] -> m (DynFlags, [Located FilePath], [Warn])
parseDynamicFlagsCmdLine DynFlags
dflags [Located FilePath]
cmdline
  DynFlags
dflags2 <- IO DynFlags -> m DynFlags
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO DynFlags -> m DynFlags) -> IO DynFlags -> m DynFlags
forall a b. (a -> b) -> a -> b
$ Logger -> DynFlags -> IO DynFlags
interpretPackageEnv Logger
logger DynFlags
dflags1
  (DynFlags, [Located FilePath], [Warn])
-> m (DynFlags, [Located FilePath], [Warn])
forall (m :: * -> *) a. Monad m => a -> m a
return (DynFlags
dflags2, [Located FilePath]
leftovers, [Warn]
warns)

-- | Parse command line arguments that look like files.
-- First normalises its arguments and then splits them into source files
-- and object files.
-- A source file can be turned into a 'Target' via 'guessTarget'
parseTargetFiles :: DynFlags -> [String] -> (DynFlags, [(String, Maybe Phase)], [String])
parseTargetFiles :: DynFlags
-> [FilePath] -> (DynFlags, [(FilePath, Maybe Phase)], [FilePath])
parseTargetFiles DynFlags
dflags0 [FilePath]
fileish_args =
  let
    normal_fileish_paths :: [FilePath]
normal_fileish_paths = (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> FilePath
normalise_hyp [FilePath]
fileish_args
    ([(FilePath, Maybe Phase)]
srcs, [FilePath]
objs)         = [FilePath]
-> [(FilePath, Maybe Phase)]
-> [FilePath]
-> ([(FilePath, Maybe Phase)], [FilePath])
partition_args [FilePath]
normal_fileish_paths [] []

    dflags1 :: DynFlags
dflags1 = DynFlags
dflags0 { ldInputs :: [Option]
ldInputs = (FilePath -> Option) -> [FilePath] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> FilePath -> Option
FileOption FilePath
"") [FilePath]
objs
                                   [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ DynFlags -> [Option]
ldInputs DynFlags
dflags0 }
    {-
      We split out the object files (.o, .dll) and add them
      to ldInputs for use by the linker.

      The following things should be considered compilation manager inputs:

       - haskell source files (strings ending in .hs, .lhs or other
         haskellish extension),

       - module names (not forgetting hierarchical module names),

       - things beginning with '-' are flags that were not recognised by
         the flag parser, and we want them to generate errors later in
         checkOptions, so we class them as source files (#5921)

       - and finally we consider everything without an extension to be
         a comp manager input, as shorthand for a .hs or .lhs filename.

      Everything else is considered to be a linker object, and passed
      straight through to the linker.
    -}
  in (DynFlags
dflags1, [(FilePath, Maybe Phase)]
srcs, [FilePath]
objs)

-- -----------------------------------------------------------------------------

-- | Splitting arguments into source files and object files.  This is where we
-- interpret the -x <suffix> option, and attach a (Maybe Phase) to each source
-- file indicating the phase specified by the -x option in force, if any.
partition_args :: [String] -> [(String, Maybe Phase)] -> [String]
               -> ([(String, Maybe Phase)], [String])
partition_args :: [FilePath]
-> [(FilePath, Maybe Phase)]
-> [FilePath]
-> ([(FilePath, Maybe Phase)], [FilePath])
partition_args [] [(FilePath, Maybe Phase)]
srcs [FilePath]
objs = ([(FilePath, Maybe Phase)] -> [(FilePath, Maybe Phase)]
forall a. [a] -> [a]
reverse [(FilePath, Maybe Phase)]
srcs, [FilePath] -> [FilePath]
forall a. [a] -> [a]
reverse [FilePath]
objs)
partition_args (FilePath
"-x":FilePath
suff:[FilePath]
args) [(FilePath, Maybe Phase)]
srcs [FilePath]
objs
  | FilePath
"none" <- FilePath
suff      = [FilePath]
-> [(FilePath, Maybe Phase)]
-> [FilePath]
-> ([(FilePath, Maybe Phase)], [FilePath])
partition_args [FilePath]
args [(FilePath, Maybe Phase)]
srcs [FilePath]
objs
  | Phase
StopLn <- Phase
phase     = [FilePath]
-> [(FilePath, Maybe Phase)]
-> [FilePath]
-> ([(FilePath, Maybe Phase)], [FilePath])
partition_args [FilePath]
args [(FilePath, Maybe Phase)]
srcs ([FilePath]
slurp [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
objs)
  | Bool
otherwise           = [FilePath]
-> [(FilePath, Maybe Phase)]
-> [FilePath]
-> ([(FilePath, Maybe Phase)], [FilePath])
partition_args [FilePath]
rest ([(FilePath, Maybe Phase)]
these_srcs [(FilePath, Maybe Phase)]
-> [(FilePath, Maybe Phase)] -> [(FilePath, Maybe Phase)]
forall a. [a] -> [a] -> [a]
++ [(FilePath, Maybe Phase)]
srcs) [FilePath]
objs
        where phase :: Phase
phase = FilePath -> Phase
startPhase FilePath
suff
              ([FilePath]
slurp,[FilePath]
rest) = (FilePath -> Bool) -> [FilePath] -> ([FilePath], [FilePath])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"-x") [FilePath]
args
              these_srcs :: [(FilePath, Maybe Phase)]
these_srcs = [FilePath] -> [Maybe Phase] -> [(FilePath, Maybe Phase)]
forall a b. [a] -> [b] -> [(a, b)]
zip [FilePath]
slurp (Maybe Phase -> [Maybe Phase]
forall a. a -> [a]
repeat (Phase -> Maybe Phase
forall a. a -> Maybe a
Just Phase
phase))
partition_args (FilePath
arg:[FilePath]
args) [(FilePath, Maybe Phase)]
srcs [FilePath]
objs
  | FilePath -> Bool
looks_like_an_input FilePath
arg = [FilePath]
-> [(FilePath, Maybe Phase)]
-> [FilePath]
-> ([(FilePath, Maybe Phase)], [FilePath])
partition_args [FilePath]
args ((FilePath
arg,Maybe Phase
forall a. Maybe a
Nothing)(FilePath, Maybe Phase)
-> [(FilePath, Maybe Phase)] -> [(FilePath, Maybe Phase)]
forall a. a -> [a] -> [a]
:[(FilePath, Maybe Phase)]
srcs) [FilePath]
objs
  | Bool
otherwise               = [FilePath]
-> [(FilePath, Maybe Phase)]
-> [FilePath]
-> ([(FilePath, Maybe Phase)], [FilePath])
partition_args [FilePath]
args [(FilePath, Maybe Phase)]
srcs (FilePath
argFilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:[FilePath]
objs)


looks_like_an_input :: String -> Bool
looks_like_an_input :: FilePath -> Bool
looks_like_an_input FilePath
m =  FilePath -> Bool
isSourceFilename FilePath
m
                      Bool -> Bool -> Bool
|| FilePath -> Bool
looksLikeModuleName FilePath
m
                      Bool -> Bool -> Bool
|| FilePath
"-" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` FilePath
m
                      Bool -> Bool -> Bool
|| Bool -> Bool
not (FilePath -> Bool
hasExtension FilePath
m)


-- | To simplify the handling of filepaths, we normalise all filepaths right
-- away. Note the asymmetry of FilePath.normalise:
--    Linux:   p\/q -> p\/q; p\\q -> p\\q
--    Windows: p\/q -> p\\q; p\\q -> p\\q
-- #12674: Filenames starting with a hyphen get normalised from ./-foo.hs
-- to -foo.hs. We have to re-prepend the current directory.
normalise_hyp :: FilePath -> FilePath
normalise_hyp :: FilePath -> FilePath
normalise_hyp FilePath
fp
  | Bool
strt_dot_sl Bool -> Bool -> Bool
&& FilePath
"-" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` FilePath
nfp = FilePath
cur_dir FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
nfp
  | Bool
otherwise                           = FilePath
nfp
  where
#if defined(mingw32_HOST_OS)
    strt_dot_sl = "./" `isPrefixOf` fp || ".\\" `isPrefixOf` fp
#else
    strt_dot_sl :: Bool
strt_dot_sl = FilePath
"./" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` FilePath
fp
#endif
    cur_dir :: FilePath
cur_dir = Char
'.' Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: [Char
pathSeparator]
    nfp :: FilePath
nfp = FilePath -> FilePath
normalise FilePath
fp

-----------------------------------------------------------------------------

-- | Checks the set of new DynFlags for possibly erroneous option
-- combinations when invoking 'setSessionDynFlags' and friends, and if
-- found, returns a fixed copy (if possible).
checkNewDynFlags :: MonadIO m => Logger -> DynFlags -> m DynFlags
checkNewDynFlags :: forall (m :: * -> *). MonadIO m => Logger -> DynFlags -> m DynFlags
checkNewDynFlags Logger
logger DynFlags
dflags = do
  -- See Note [DynFlags consistency]
  let (DynFlags
dflags', [Located FilePath]
warnings) = DynFlags -> (DynFlags, [Located FilePath])
makeDynFlagsConsistent DynFlags
dflags
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Logger -> DynFlags -> [Warn] -> IO ()
handleFlagWarnings Logger
logger DynFlags
dflags ((Located FilePath -> Warn) -> [Located FilePath] -> [Warn]
forall a b. (a -> b) -> [a] -> [b]
map (WarnReason -> Located FilePath -> Warn
Warn WarnReason
NoReason) [Located FilePath]
warnings)
  DynFlags -> m DynFlags
forall (m :: * -> *) a. Monad m => a -> m a
return DynFlags
dflags'

checkNewInteractiveDynFlags :: MonadIO m => Logger -> DynFlags -> m DynFlags
checkNewInteractiveDynFlags :: forall (m :: * -> *). MonadIO m => Logger -> DynFlags -> m DynFlags
checkNewInteractiveDynFlags Logger
logger DynFlags
dflags0 = do
  -- We currently don't support use of StaticPointers in expressions entered on
  -- the REPL. See #12356.
  if Extension -> DynFlags -> Bool
xopt Extension
LangExt.StaticPointers DynFlags
dflags0
  then do IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Logger -> DynFlags -> Bag WarnMsg -> IO ()
printOrThrowWarnings Logger
logger DynFlags
dflags0 (Bag WarnMsg -> IO ()) -> Bag WarnMsg -> IO ()
forall a b. (a -> b) -> a -> b
$ [WarnMsg] -> Bag WarnMsg
forall a. [a] -> Bag a
listToBag
            [SrcSpan -> SDoc -> WarnMsg
mkPlainWarnMsg SrcSpan
interactiveSrcSpan
             (SDoc -> WarnMsg) -> SDoc -> WarnMsg
forall a b. (a -> b) -> a -> b
$ FilePath -> SDoc
text FilePath
"StaticPointers is not supported in GHCi interactive expressions."]
          DynFlags -> m DynFlags
forall (m :: * -> *) a. Monad m => a -> m a
return (DynFlags -> m DynFlags) -> DynFlags -> m DynFlags
forall a b. (a -> b) -> a -> b
$ DynFlags -> Extension -> DynFlags
xopt_unset DynFlags
dflags0 Extension
LangExt.StaticPointers
  else DynFlags -> m DynFlags
forall (m :: * -> *) a. Monad m => a -> m a
return DynFlags
dflags0


-- %************************************************************************
-- %*                                                                      *
--             Setting, getting, and modifying the targets
-- %*                                                                      *
-- %************************************************************************

-- ToDo: think about relative vs. absolute file paths. And what
-- happens when the current directory changes.

-- | Sets the targets for this session.  Each target may be a module name
-- or a filename.  The targets correspond to the set of root modules for
-- the program\/library.  Unloading the current program is achieved by
-- setting the current set of targets to be empty, followed by 'load'.
setTargets :: GhcMonad m => [Target] -> m ()
setTargets :: forall (m :: * -> *). GhcMonad m => [Target] -> m ()
setTargets [Target]
targets = (HscEnv -> HscEnv) -> m ()
forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession (\HscEnv
h -> HscEnv
h{ hsc_targets :: [Target]
hsc_targets = [Target]
targets })

-- | Returns the current set of targets
getTargets :: GhcMonad m => m [Target]
getTargets :: forall (m :: * -> *). GhcMonad m => m [Target]
getTargets = (HscEnv -> m [Target]) -> m [Target]
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ([Target] -> m [Target]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Target] -> m [Target])
-> (HscEnv -> [Target]) -> HscEnv -> m [Target]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv -> [Target]
hsc_targets)

-- | Add another target.
addTarget :: GhcMonad m => Target -> m ()
addTarget :: forall (m :: * -> *). GhcMonad m => Target -> m ()
addTarget Target
target
  = (HscEnv -> HscEnv) -> m ()
forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession (\HscEnv
h -> HscEnv
h{ hsc_targets :: [Target]
hsc_targets = Target
target Target -> [Target] -> [Target]
forall a. a -> [a] -> [a]
: HscEnv -> [Target]
hsc_targets HscEnv
h })

-- | Remove a target
removeTarget :: GhcMonad m => TargetId -> m ()
removeTarget :: forall (m :: * -> *). GhcMonad m => TargetId -> m ()
removeTarget TargetId
target_id
  = (HscEnv -> HscEnv) -> m ()
forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession (\HscEnv
h -> HscEnv
h{ hsc_targets :: [Target]
hsc_targets = [Target] -> [Target]
filter (HscEnv -> [Target]
hsc_targets HscEnv
h) })
  where
   filter :: [Target] -> [Target]
filter [Target]
targets = [ Target
t | t :: Target
t@(Target TargetId
id Bool
_ Maybe (InputFileBuffer, UTCTime)
_) <- [Target]
targets, TargetId
id TargetId -> TargetId -> Bool
forall a. Eq a => a -> a -> Bool
/= TargetId
target_id ]

-- | Attempts to guess what Target a string refers to.  This function
-- implements the @--make@/GHCi command-line syntax for filenames:
--
--   - if the string looks like a Haskell source filename, then interpret it
--     as such
--
--   - if adding a .hs or .lhs suffix yields the name of an existing file,
--     then use that
--
--   - otherwise interpret the string as a module name
--
guessTarget :: GhcMonad m => String -> Maybe Phase -> m Target
guessTarget :: forall (m :: * -> *).
GhcMonad m =>
FilePath -> Maybe Phase -> m Target
guessTarget FilePath
str (Just Phase
phase)
   = Target -> m Target
forall (m :: * -> *) a. Monad m => a -> m a
return (TargetId -> Bool -> Maybe (InputFileBuffer, UTCTime) -> Target
Target (FilePath -> Maybe Phase -> TargetId
TargetFile FilePath
str (Phase -> Maybe Phase
forall a. a -> Maybe a
Just Phase
phase)) Bool
True Maybe (InputFileBuffer, UTCTime)
forall a. Maybe a
Nothing)
guessTarget FilePath
str Maybe Phase
Nothing
   | FilePath -> Bool
isHaskellSrcFilename FilePath
file
   = Target -> m Target
forall (m :: * -> *) a. Monad m => a -> m a
return (TargetId -> Target
target (FilePath -> Maybe Phase -> TargetId
TargetFile FilePath
file Maybe Phase
forall a. Maybe a
Nothing))
   | Bool
otherwise
   = do Bool
exists <- IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesFileExist FilePath
hs_file
        if Bool
exists
           then Target -> m Target
forall (m :: * -> *) a. Monad m => a -> m a
return (TargetId -> Target
target (FilePath -> Maybe Phase -> TargetId
TargetFile FilePath
hs_file Maybe Phase
forall a. Maybe a
Nothing))
           else do
        Bool
exists <- IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesFileExist FilePath
lhs_file
        if Bool
exists
           then Target -> m Target
forall (m :: * -> *) a. Monad m => a -> m a
return (TargetId -> Target
target (FilePath -> Maybe Phase -> TargetId
TargetFile FilePath
lhs_file Maybe Phase
forall a. Maybe a
Nothing))
           else do
        if FilePath -> Bool
looksLikeModuleName FilePath
file
           then Target -> m Target
forall (m :: * -> *) a. Monad m => a -> m a
return (TargetId -> Target
target (ModuleName -> TargetId
TargetModule (FilePath -> ModuleName
mkModuleName FilePath
file)))
           else do
        DynFlags
dflags <- m DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
        IO Target -> m Target
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Target -> m Target) -> IO Target -> m Target
forall a b. (a -> b) -> a -> b
$ GhcException -> IO Target
forall a. GhcException -> IO a
throwGhcExceptionIO
                 (FilePath -> GhcException
ProgramError (DynFlags -> SDoc -> FilePath
showSDoc DynFlags
dflags (SDoc -> FilePath) -> SDoc -> FilePath
forall a b. (a -> b) -> a -> b
$
                 FilePath -> SDoc
text FilePath
"target" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (FilePath -> SDoc
text FilePath
file) SDoc -> SDoc -> SDoc
<+>
                 FilePath -> SDoc
text FilePath
"is not a module name or a source file"))
     where
         (FilePath
file,Bool
obj_allowed)
                | Char
'*':FilePath
rest <- FilePath
str = (FilePath
rest, Bool
False)
                | Bool
otherwise       = (FilePath
str,  Bool
True)

         hs_file :: FilePath
hs_file  = FilePath
file FilePath -> FilePath -> FilePath
<.> FilePath
"hs"
         lhs_file :: FilePath
lhs_file = FilePath
file FilePath -> FilePath -> FilePath
<.> FilePath
"lhs"

         target :: TargetId -> Target
target TargetId
tid = TargetId -> Bool -> Maybe (InputFileBuffer, UTCTime) -> Target
Target TargetId
tid Bool
obj_allowed Maybe (InputFileBuffer, UTCTime)
forall a. Maybe a
Nothing


-- | Inform GHC that the working directory has changed.  GHC will flush
-- its cache of module locations, since it may no longer be valid.
--
-- Note: Before changing the working directory make sure all threads running
-- in the same session have stopped.  If you change the working directory,
-- you should also unload the current program (set targets to empty,
-- followed by load).
workingDirectoryChanged :: GhcMonad m => m ()
workingDirectoryChanged :: forall (m :: * -> *). GhcMonad m => m ()
workingDirectoryChanged = (HscEnv -> m ()) -> m ()
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m ()) -> m ()) -> (HscEnv -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ (IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (HscEnv -> IO ()) -> HscEnv -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv -> IO ()
flushFinderCaches)


-- %************************************************************************
-- %*                                                                      *
--             Running phases one at a time
-- %*                                                                      *
-- %************************************************************************

class ParsedMod m where
  modSummary   :: m -> ModSummary
  parsedSource :: m -> ParsedSource

class ParsedMod m => TypecheckedMod m where
  renamedSource     :: m -> Maybe RenamedSource
  typecheckedSource :: m -> TypecheckedSource
  moduleInfo        :: m -> ModuleInfo
  tm_internals      :: m -> (TcGblEnv, ModDetails)
        -- ToDo: improvements that could be made here:
        --  if the module succeeded renaming but not typechecking,
        --  we can still get back the GlobalRdrEnv and exports, so
        --  perhaps the ModuleInfo should be split up into separate
        --  fields.

class TypecheckedMod m => DesugaredMod m where
  coreModule :: m -> ModGuts

-- | The result of successful parsing.
data ParsedModule =
  ParsedModule { ParsedModule -> ModSummary
pm_mod_summary   :: ModSummary
               , ParsedModule -> ParsedSource
pm_parsed_source :: ParsedSource
               , ParsedModule -> [FilePath]
pm_extra_src_files :: [FilePath] }

instance ParsedMod ParsedModule where
  modSummary :: ParsedModule -> ModSummary
modSummary ParsedModule
m    = ParsedModule -> ModSummary
pm_mod_summary ParsedModule
m
  parsedSource :: ParsedModule -> ParsedSource
parsedSource ParsedModule
m = ParsedModule -> ParsedSource
pm_parsed_source ParsedModule
m

-- | The result of successful typechecking.  It also contains the parser
--   result.
data TypecheckedModule =
  TypecheckedModule { TypecheckedModule -> ParsedModule
tm_parsed_module       :: ParsedModule
                    , TypecheckedModule -> Maybe RenamedSource
tm_renamed_source      :: Maybe RenamedSource
                    , TypecheckedModule -> TypecheckedSource
tm_typechecked_source  :: TypecheckedSource
                    , TypecheckedModule -> ModuleInfo
tm_checked_module_info :: ModuleInfo
                    , TypecheckedModule -> (TcGblEnv, ModDetails)
tm_internals_          :: (TcGblEnv, ModDetails)
                    }

instance ParsedMod TypecheckedModule where
  modSummary :: TypecheckedModule -> ModSummary
modSummary TypecheckedModule
m   = ParsedModule -> ModSummary
forall m. ParsedMod m => m -> ModSummary
modSummary (TypecheckedModule -> ParsedModule
tm_parsed_module TypecheckedModule
m)
  parsedSource :: TypecheckedModule -> ParsedSource
parsedSource TypecheckedModule
m = ParsedModule -> ParsedSource
forall m. ParsedMod m => m -> ParsedSource
parsedSource (TypecheckedModule -> ParsedModule
tm_parsed_module TypecheckedModule
m)

instance TypecheckedMod TypecheckedModule where
  renamedSource :: TypecheckedModule -> Maybe RenamedSource
renamedSource TypecheckedModule
m     = TypecheckedModule -> Maybe RenamedSource
tm_renamed_source TypecheckedModule
m
  typecheckedSource :: TypecheckedModule -> TypecheckedSource
typecheckedSource TypecheckedModule
m = TypecheckedModule -> TypecheckedSource
tm_typechecked_source TypecheckedModule
m
  moduleInfo :: TypecheckedModule -> ModuleInfo
moduleInfo TypecheckedModule
m        = TypecheckedModule -> ModuleInfo
tm_checked_module_info TypecheckedModule
m
  tm_internals :: TypecheckedModule -> (TcGblEnv, ModDetails)
tm_internals TypecheckedModule
m      = TypecheckedModule -> (TcGblEnv, ModDetails)
tm_internals_ TypecheckedModule
m

-- | The result of successful desugaring (i.e., translation to core).  Also
--  contains all the information of a typechecked module.
data DesugaredModule =
  DesugaredModule { DesugaredModule -> TypecheckedModule
dm_typechecked_module :: TypecheckedModule
                  , DesugaredModule -> ModGuts
dm_core_module        :: ModGuts
             }

instance ParsedMod DesugaredModule where
  modSummary :: DesugaredModule -> ModSummary
modSummary DesugaredModule
m   = TypecheckedModule -> ModSummary
forall m. ParsedMod m => m -> ModSummary
modSummary (DesugaredModule -> TypecheckedModule
dm_typechecked_module DesugaredModule
m)
  parsedSource :: DesugaredModule -> ParsedSource
parsedSource DesugaredModule
m = TypecheckedModule -> ParsedSource
forall m. ParsedMod m => m -> ParsedSource
parsedSource (DesugaredModule -> TypecheckedModule
dm_typechecked_module DesugaredModule
m)

instance TypecheckedMod DesugaredModule where
  renamedSource :: DesugaredModule -> Maybe RenamedSource
renamedSource DesugaredModule
m     = TypecheckedModule -> Maybe RenamedSource
forall m. TypecheckedMod m => m -> Maybe RenamedSource
renamedSource (DesugaredModule -> TypecheckedModule
dm_typechecked_module DesugaredModule
m)
  typecheckedSource :: DesugaredModule -> TypecheckedSource
typecheckedSource DesugaredModule
m = TypecheckedModule -> TypecheckedSource
forall m. TypecheckedMod m => m -> TypecheckedSource
typecheckedSource (DesugaredModule -> TypecheckedModule
dm_typechecked_module DesugaredModule
m)
  moduleInfo :: DesugaredModule -> ModuleInfo
moduleInfo DesugaredModule
m        = TypecheckedModule -> ModuleInfo
forall m. TypecheckedMod m => m -> ModuleInfo
moduleInfo (DesugaredModule -> TypecheckedModule
dm_typechecked_module DesugaredModule
m)
  tm_internals :: DesugaredModule -> (TcGblEnv, ModDetails)
tm_internals DesugaredModule
m      = TypecheckedModule -> (TcGblEnv, ModDetails)
tm_internals_ (DesugaredModule -> TypecheckedModule
dm_typechecked_module DesugaredModule
m)

instance DesugaredMod DesugaredModule where
  coreModule :: DesugaredModule -> ModGuts
coreModule DesugaredModule
m = DesugaredModule -> ModGuts
dm_core_module DesugaredModule
m

type ParsedSource      = Located HsModule
type RenamedSource     = (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [(LIE GhcRn, Avails)],
                          Maybe LHsDocString)
type TypecheckedSource = LHsBinds GhcTc

-- NOTE:
--   - things that aren't in the output of the typechecker right now:
--     - the export list
--     - the imports
--     - type signatures
--     - type/data/newtype declarations
--     - class declarations
--     - instances
--   - extra things in the typechecker's output:
--     - default methods are turned into top-level decls.
--     - dictionary bindings

-- | Return the 'ModSummary' of a module with the given name.
--
-- The module must be part of the module graph (see 'hsc_mod_graph' and
-- 'ModuleGraph').  If this is not the case, this function will throw a
-- 'GhcApiError'.
--
-- This function ignores boot modules and requires that there is only one
-- non-boot module with the given name.
getModSummary :: GhcMonad m => ModuleName -> m ModSummary
getModSummary :: forall (m :: * -> *). GhcMonad m => ModuleName -> m ModSummary
getModSummary ModuleName
mod = do
   ModuleGraph
mg <- (HscEnv -> ModuleGraph) -> m HscEnv -> m ModuleGraph
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM HscEnv -> ModuleGraph
hsc_mod_graph m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
   let mods_by_name :: [ModSummary]
mods_by_name = [ ModSummary
ms | ModSummary
ms <- ModuleGraph -> [ModSummary]
mgModSummaries ModuleGraph
mg
                      , ModSummary -> ModuleName
ms_mod_name ModSummary
ms ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
== ModuleName
mod
                      , ModSummary -> IsBootInterface
isBootSummary ModSummary
ms IsBootInterface -> IsBootInterface -> Bool
forall a. Eq a => a -> a -> Bool
== IsBootInterface
NotBoot ]
   case [ModSummary]
mods_by_name of
     [] -> do DynFlags
dflags <- m DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
              IO ModSummary -> m ModSummary
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ModSummary -> m ModSummary) -> IO ModSummary -> m ModSummary
forall a b. (a -> b) -> a -> b
$ GhcApiError -> IO ModSummary
forall e a. Exception e => e -> IO a
throwIO (GhcApiError -> IO ModSummary) -> GhcApiError -> IO ModSummary
forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> GhcApiError
mkApiErr DynFlags
dflags (FilePath -> SDoc
text FilePath
"Module not part of module graph")
     [ModSummary
ms] -> ModSummary -> m ModSummary
forall (m :: * -> *) a. Monad m => a -> m a
return ModSummary
ms
     [ModSummary]
multiple -> do DynFlags
dflags <- m DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
                    IO ModSummary -> m ModSummary
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ModSummary -> m ModSummary) -> IO ModSummary -> m ModSummary
forall a b. (a -> b) -> a -> b
$ GhcApiError -> IO ModSummary
forall e a. Exception e => e -> IO a
throwIO (GhcApiError -> IO ModSummary) -> GhcApiError -> IO ModSummary
forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> GhcApiError
mkApiErr DynFlags
dflags (FilePath -> SDoc
text FilePath
"getModSummary is ambiguous: " SDoc -> SDoc -> SDoc
<+> [ModSummary] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ModSummary]
multiple)

-- | Parse a module.
--
-- Throws a 'SourceError' on parse error.
parseModule :: GhcMonad m => ModSummary -> m ParsedModule
parseModule :: forall (m :: * -> *). GhcMonad m => ModSummary -> m ParsedModule
parseModule ModSummary
ms = do
   HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
   let hsc_env_tmp :: HscEnv
hsc_env_tmp = HscEnv
hsc_env { hsc_dflags :: DynFlags
hsc_dflags = ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms }
   HsParsedModule
hpm <- IO HsParsedModule -> m HsParsedModule
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO HsParsedModule -> m HsParsedModule)
-> IO HsParsedModule -> m HsParsedModule
forall a b. (a -> b) -> a -> b
$ HscEnv -> ModSummary -> IO HsParsedModule
hscParse HscEnv
hsc_env_tmp ModSummary
ms
   ParsedModule -> m ParsedModule
forall (m :: * -> *) a. Monad m => a -> m a
return (ModSummary -> ParsedSource -> [FilePath] -> ParsedModule
ParsedModule ModSummary
ms (HsParsedModule -> ParsedSource
hpm_module HsParsedModule
hpm) (HsParsedModule -> [FilePath]
hpm_src_files HsParsedModule
hpm))
               -- See Note [exact print annotations] in GHC.Parser.Annotation

-- | Typecheck and rename a parsed module.
--
-- Throws a 'SourceError' if either fails.
typecheckModule :: GhcMonad m => ParsedModule -> m TypecheckedModule
typecheckModule :: forall (m :: * -> *).
GhcMonad m =>
ParsedModule -> m TypecheckedModule
typecheckModule ParsedModule
pmod = do
 let ms :: ModSummary
ms = ParsedModule -> ModSummary
forall m. ParsedMod m => m -> ModSummary
modSummary ParsedModule
pmod
 HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
 let hsc_env_tmp :: HscEnv
hsc_env_tmp = HscEnv
hsc_env { hsc_dflags :: DynFlags
hsc_dflags = ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms }
 (TcGblEnv
tc_gbl_env, Maybe
  (HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
   Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
   Maybe LHsDocString)
rn_info)
       <- IO
  (TcGblEnv,
   Maybe
     (HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
      Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
      Maybe LHsDocString))
-> m (TcGblEnv,
      Maybe
        (HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
         Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
         Maybe LHsDocString))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO
   (TcGblEnv,
    Maybe
      (HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
       Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
       Maybe LHsDocString))
 -> m (TcGblEnv,
       Maybe
         (HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
          Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
          Maybe LHsDocString)))
-> IO
     (TcGblEnv,
      Maybe
        (HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
         Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
         Maybe LHsDocString))
-> m (TcGblEnv,
      Maybe
        (HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
         Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
         Maybe LHsDocString))
forall a b. (a -> b) -> a -> b
$ HscEnv
-> ModSummary
-> HsParsedModule
-> IO (TcGblEnv, Maybe RenamedSource)
hscTypecheckRename HscEnv
hsc_env_tmp ModSummary
ms (HsParsedModule -> IO (TcGblEnv, Maybe RenamedSource))
-> HsParsedModule -> IO (TcGblEnv, Maybe RenamedSource)
forall a b. (a -> b) -> a -> b
$
                      HsParsedModule { hpm_module :: ParsedSource
hpm_module = ParsedModule -> ParsedSource
forall m. ParsedMod m => m -> ParsedSource
parsedSource ParsedModule
pmod,
                                       hpm_src_files :: [FilePath]
hpm_src_files = ParsedModule -> [FilePath]
pm_extra_src_files ParsedModule
pmod }
 ModDetails
details <- IO ModDetails -> m ModDetails
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ModDetails -> m ModDetails) -> IO ModDetails -> m ModDetails
forall a b. (a -> b) -> a -> b
$ HscEnv -> TcGblEnv -> IO ModDetails
makeSimpleDetails HscEnv
hsc_env_tmp TcGblEnv
tc_gbl_env
 SafeHaskellMode
safe    <- IO SafeHaskellMode -> m SafeHaskellMode
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO SafeHaskellMode -> m SafeHaskellMode)
-> IO SafeHaskellMode -> m SafeHaskellMode
forall a b. (a -> b) -> a -> b
$ DynFlags -> TcGblEnv -> IO SafeHaskellMode
finalSafeMode (ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms) TcGblEnv
tc_gbl_env

 TypecheckedModule -> m TypecheckedModule
forall (m :: * -> *) a. Monad m => a -> m a
return (TypecheckedModule -> m TypecheckedModule)
-> TypecheckedModule -> m TypecheckedModule
forall a b. (a -> b) -> a -> b
$
     TypecheckedModule {
       tm_internals_ :: (TcGblEnv, ModDetails)
tm_internals_          = (TcGblEnv
tc_gbl_env, ModDetails
details),
       tm_parsed_module :: ParsedModule
tm_parsed_module       = ParsedModule
pmod,
       tm_renamed_source :: Maybe RenamedSource
tm_renamed_source      = Maybe
  (HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
   Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
   Maybe LHsDocString)
Maybe RenamedSource
rn_info,
       tm_typechecked_source :: TypecheckedSource
tm_typechecked_source  = TcGblEnv -> TypecheckedSource
tcg_binds TcGblEnv
tc_gbl_env,
       tm_checked_module_info :: ModuleInfo
tm_checked_module_info =
         ModuleInfo {
           minf_type_env :: TypeEnv
minf_type_env  = ModDetails -> TypeEnv
md_types ModDetails
details,
           minf_exports :: Avails
minf_exports   = ModDetails -> Avails
md_exports ModDetails
details,
           minf_rdr_env :: Maybe GlobalRdrEnv
minf_rdr_env   = GlobalRdrEnv -> Maybe GlobalRdrEnv
forall a. a -> Maybe a
Just (TcGblEnv -> GlobalRdrEnv
tcg_rdr_env TcGblEnv
tc_gbl_env),
           minf_instances :: [ClsInst]
minf_instances = SafeHaskellMode -> [ClsInst] -> [ClsInst]
fixSafeInstances SafeHaskellMode
safe ([ClsInst] -> [ClsInst]) -> [ClsInst] -> [ClsInst]
forall a b. (a -> b) -> a -> b
$ ModDetails -> [ClsInst]
md_insts ModDetails
details,
           minf_iface :: Maybe ModIface
minf_iface     = Maybe ModIface
forall a. Maybe a
Nothing,
           minf_safe :: SafeHaskellMode
minf_safe      = SafeHaskellMode
safe,
           minf_modBreaks :: ModBreaks
minf_modBreaks = ModBreaks
emptyModBreaks
         }}

-- | Desugar a typechecked module.
desugarModule :: GhcMonad m => TypecheckedModule -> m DesugaredModule
desugarModule :: forall (m :: * -> *).
GhcMonad m =>
TypecheckedModule -> m DesugaredModule
desugarModule TypecheckedModule
tcm = do
 let ms :: ModSummary
ms = TypecheckedModule -> ModSummary
forall m. ParsedMod m => m -> ModSummary
modSummary TypecheckedModule
tcm
 let (TcGblEnv
tcg, ModDetails
_) = TypecheckedModule -> (TcGblEnv, ModDetails)
forall m. TypecheckedMod m => m -> (TcGblEnv, ModDetails)
tm_internals TypecheckedModule
tcm
 HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
 let hsc_env_tmp :: HscEnv
hsc_env_tmp = HscEnv
hsc_env { hsc_dflags :: DynFlags
hsc_dflags = ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms }
 ModGuts
guts <- IO ModGuts -> m ModGuts
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ModGuts -> m ModGuts) -> IO ModGuts -> m ModGuts
forall a b. (a -> b) -> a -> b
$ HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts
hscDesugar HscEnv
hsc_env_tmp ModSummary
ms TcGblEnv
tcg
 DesugaredModule -> m DesugaredModule
forall (m :: * -> *) a. Monad m => a -> m a
return (DesugaredModule -> m DesugaredModule)
-> DesugaredModule -> m DesugaredModule
forall a b. (a -> b) -> a -> b
$
     DesugaredModule {
       dm_typechecked_module :: TypecheckedModule
dm_typechecked_module = TypecheckedModule
tcm,
       dm_core_module :: ModGuts
dm_core_module        = ModGuts
guts
     }

-- | Load a module.  Input doesn't need to be desugared.
--
-- A module must be loaded before dependent modules can be typechecked.  This
-- always includes generating a 'ModIface' and, depending on the
-- @DynFlags@\'s 'GHC.Driver.Session.backend', may also include code generation.
--
-- This function will always cause recompilation and will always overwrite
-- previous compilation results (potentially files on disk).
--
loadModule :: (TypecheckedMod mod, GhcMonad m) => mod -> m mod
loadModule :: forall mod (m :: * -> *).
(TypecheckedMod mod, GhcMonad m) =>
mod -> m mod
loadModule mod
tcm = do
   let ms :: ModSummary
ms = mod -> ModSummary
forall m. ParsedMod m => m -> ModSummary
modSummary mod
tcm
   let mod :: ModuleName
mod = ModSummary -> ModuleName
ms_mod_name ModSummary
ms
   let loc :: ModLocation
loc = ModSummary -> ModLocation
ms_location ModSummary
ms
   let (TcGblEnv
tcg, ModDetails
_details) = mod -> (TcGblEnv, ModDetails)
forall m. TypecheckedMod m => m -> (TcGblEnv, ModDetails)
tm_internals mod
tcm

   Maybe Linkable
mb_linkable <- case ModSummary -> Maybe UTCTime
ms_obj_date ModSummary
ms of
                     Just UTCTime
t | UTCTime
t UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
> ModSummary -> UTCTime
ms_hs_date ModSummary
ms  -> do
                         Linkable
l <- IO Linkable -> m Linkable
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Linkable -> m Linkable) -> IO Linkable -> m Linkable
forall a b. (a -> b) -> a -> b
$ Module -> FilePath -> UTCTime -> IO Linkable
findObjectLinkable (ModSummary -> Module
ms_mod ModSummary
ms)
                                                  (ModLocation -> FilePath
ml_obj_file ModLocation
loc) UTCTime
t
                         Maybe Linkable -> m (Maybe Linkable)
forall (m :: * -> *) a. Monad m => a -> m a
return (Linkable -> Maybe Linkable
forall a. a -> Maybe a
Just Linkable
l)
                     Maybe UTCTime
_otherwise -> Maybe Linkable -> m (Maybe Linkable)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Linkable
forall a. Maybe a
Nothing

   let source_modified :: SourceModified
source_modified | Maybe Linkable -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Linkable
mb_linkable = SourceModified
SourceModified
                       | Bool
otherwise             = SourceModified
SourceUnmodified
                       -- we can't determine stability here

   -- compile doesn't change the session
   HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
   HomeModInfo
mod_info <- IO HomeModInfo -> m HomeModInfo
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO HomeModInfo -> m HomeModInfo)
-> IO HomeModInfo -> m HomeModInfo
forall a b. (a -> b) -> a -> b
$ Maybe TcGblEnv
-> Maybe Messager
-> HscEnv
-> ModSummary
-> Int
-> Int
-> Maybe ModIface
-> Maybe Linkable
-> SourceModified
-> IO HomeModInfo
compileOne' (TcGblEnv -> Maybe TcGblEnv
forall a. a -> Maybe a
Just TcGblEnv
tcg) Maybe Messager
forall a. Maybe a
Nothing
                                    HscEnv
hsc_env ModSummary
ms Int
1 Int
1 Maybe ModIface
forall a. Maybe a
Nothing Maybe Linkable
mb_linkable
                                    SourceModified
source_modified

   (HscEnv -> HscEnv) -> m ()
forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession ((HscEnv -> HscEnv) -> m ()) -> (HscEnv -> HscEnv) -> m ()
forall a b. (a -> b) -> a -> b
$ \HscEnv
e -> HscEnv
e{ hsc_HPT :: HomePackageTable
hsc_HPT = HomePackageTable -> ModuleName -> HomeModInfo -> HomePackageTable
addToHpt (HscEnv -> HomePackageTable
hsc_HPT HscEnv
e) ModuleName
mod HomeModInfo
mod_info }
   mod -> m mod
forall (m :: * -> *) a. Monad m => a -> m a
return mod
tcm


-- %************************************************************************
-- %*                                                                      *
--             Dealing with Core
-- %*                                                                      *
-- %************************************************************************

-- | A CoreModule consists of just the fields of a 'ModGuts' that are needed for
-- the 'GHC.compileToCoreModule' interface.
data CoreModule
  = CoreModule {
      -- | Module name
      CoreModule -> Module
cm_module   :: !Module,
      -- | Type environment for types declared in this module
      CoreModule -> TypeEnv
cm_types    :: !TypeEnv,
      -- | Declarations
      CoreModule -> CoreProgram
cm_binds    :: CoreProgram,
      -- | Safe Haskell mode
      CoreModule -> SafeHaskellMode
cm_safe     :: SafeHaskellMode
    }

instance Outputable CoreModule where
   ppr :: CoreModule -> SDoc
ppr (CoreModule {cm_module :: CoreModule -> Module
cm_module = Module
mn, cm_types :: CoreModule -> TypeEnv
cm_types = TypeEnv
te, cm_binds :: CoreModule -> CoreProgram
cm_binds = CoreProgram
cb,
                    cm_safe :: CoreModule -> SafeHaskellMode
cm_safe = SafeHaskellMode
sf})
    = FilePath -> SDoc
text FilePath
"%module" SDoc -> SDoc -> SDoc
<+> Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
mn SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
parens (SafeHaskellMode -> SDoc
forall a. Outputable a => a -> SDoc
ppr SafeHaskellMode
sf) SDoc -> SDoc -> SDoc
<+> TypeEnv -> SDoc
forall a. Outputable a => a -> SDoc
ppr TypeEnv
te
      SDoc -> SDoc -> SDoc
$$ [SDoc] -> SDoc
vcat ((CoreBind -> SDoc) -> CoreProgram -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map CoreBind -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreProgram
cb)

-- | This is the way to get access to the Core bindings corresponding
-- to a module. 'compileToCore' parses, typechecks, and
-- desugars the module, then returns the resulting Core module (consisting of
-- the module name, type declarations, and function declarations) if
-- successful.
compileToCoreModule :: GhcMonad m => FilePath -> m CoreModule
compileToCoreModule :: forall (m :: * -> *). GhcMonad m => FilePath -> m CoreModule
compileToCoreModule = Bool -> FilePath -> m CoreModule
forall (m :: * -> *).
GhcMonad m =>
Bool -> FilePath -> m CoreModule
compileCore Bool
False

-- | Like compileToCoreModule, but invokes the simplifier, so
-- as to return simplified and tidied Core.
compileToCoreSimplified :: GhcMonad m => FilePath -> m CoreModule
compileToCoreSimplified :: forall (m :: * -> *). GhcMonad m => FilePath -> m CoreModule
compileToCoreSimplified = Bool -> FilePath -> m CoreModule
forall (m :: * -> *).
GhcMonad m =>
Bool -> FilePath -> m CoreModule
compileCore Bool
True

compileCore :: GhcMonad m => Bool -> FilePath -> m CoreModule
compileCore :: forall (m :: * -> *).
GhcMonad m =>
Bool -> FilePath -> m CoreModule
compileCore Bool
simplify FilePath
fn = do
   -- First, set the target to the desired filename
   Target
target <- FilePath -> Maybe Phase -> m Target
forall (m :: * -> *).
GhcMonad m =>
FilePath -> Maybe Phase -> m Target
guessTarget FilePath
fn Maybe Phase
forall a. Maybe a
Nothing
   Target -> m ()
forall (m :: * -> *). GhcMonad m => Target -> m ()
addTarget Target
target
   SuccessFlag
_ <- LoadHowMuch -> m SuccessFlag
forall (m :: * -> *). GhcMonad m => LoadHowMuch -> m SuccessFlag
load LoadHowMuch
LoadAllTargets
   -- Then find dependencies
   ModuleGraph
modGraph <- [ModuleName] -> Bool -> m ModuleGraph
forall (m :: * -> *).
GhcMonad m =>
[ModuleName] -> Bool -> m ModuleGraph
depanal [] Bool
True
   case (ModSummary -> Bool) -> [ModSummary] -> Maybe ModSummary
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
fn) (FilePath -> Bool)
-> (ModSummary -> FilePath) -> ModSummary -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModSummary -> FilePath
msHsFilePath) (ModuleGraph -> [ModSummary]
mgModSummaries ModuleGraph
modGraph) of
     Just ModSummary
modSummary -> do
       -- Now we have the module name;
       -- parse, typecheck and desugar the module
       (TcGblEnv
tcg, ModGuts
mod_guts) <- -- TODO: space leaky: call hsc* directly?
         do TypecheckedModule
tm <- ParsedModule -> m TypecheckedModule
forall (m :: * -> *).
GhcMonad m =>
ParsedModule -> m TypecheckedModule
typecheckModule (ParsedModule -> m TypecheckedModule)
-> m ParsedModule -> m TypecheckedModule
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ModSummary -> m ParsedModule
forall (m :: * -> *). GhcMonad m => ModSummary -> m ParsedModule
parseModule ModSummary
modSummary
            let tcg :: TcGblEnv
tcg = (TcGblEnv, ModDetails) -> TcGblEnv
forall a b. (a, b) -> a
fst (TypecheckedModule -> (TcGblEnv, ModDetails)
forall m. TypecheckedMod m => m -> (TcGblEnv, ModDetails)
tm_internals TypecheckedModule
tm)
            (,) TcGblEnv
tcg (ModGuts -> (TcGblEnv, ModGuts))
-> (DesugaredModule -> ModGuts)
-> DesugaredModule
-> (TcGblEnv, ModGuts)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DesugaredModule -> ModGuts
forall m. DesugaredMod m => m -> ModGuts
coreModule (DesugaredModule -> (TcGblEnv, ModGuts))
-> m DesugaredModule -> m (TcGblEnv, ModGuts)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypecheckedModule -> m DesugaredModule
forall (m :: * -> *).
GhcMonad m =>
TypecheckedModule -> m DesugaredModule
desugarModule TypecheckedModule
tm
       (Either (CgGuts, ModDetails) ModGuts -> CoreModule)
-> m (Either (CgGuts, ModDetails) ModGuts) -> m CoreModule
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (SafeHaskellMode
-> Either (CgGuts, ModDetails) ModGuts -> CoreModule
gutsToCoreModule (ModGuts -> SafeHaskellMode
mg_safe_haskell ModGuts
mod_guts)) (m (Either (CgGuts, ModDetails) ModGuts) -> m CoreModule)
-> m (Either (CgGuts, ModDetails) ModGuts) -> m CoreModule
forall a b. (a -> b) -> a -> b
$
         if Bool
simplify
          then do
             -- If simplify is true: simplify (hscSimplify), then tidy
             -- (tidyProgram).
             HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
             ModGuts
simpl_guts <- IO ModGuts -> m ModGuts
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ModGuts -> m ModGuts) -> IO ModGuts -> m ModGuts
forall a b. (a -> b) -> a -> b
$ do
               [FilePath]
plugins <- IORef [FilePath] -> IO [FilePath]
forall a. IORef a -> IO a
readIORef (TcGblEnv -> IORef [FilePath]
tcg_th_coreplugins TcGblEnv
tcg)
               HscEnv -> [FilePath] -> ModGuts -> IO ModGuts
hscSimplify HscEnv
hsc_env [FilePath]
plugins ModGuts
mod_guts
             (CgGuts, ModDetails)
tidy_guts <- IO (CgGuts, ModDetails) -> m (CgGuts, ModDetails)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (CgGuts, ModDetails) -> m (CgGuts, ModDetails))
-> IO (CgGuts, ModDetails) -> m (CgGuts, ModDetails)
forall a b. (a -> b) -> a -> b
$ HscEnv -> ModGuts -> IO (CgGuts, ModDetails)
tidyProgram HscEnv
hsc_env ModGuts
simpl_guts
             Either (CgGuts, ModDetails) ModGuts
-> m (Either (CgGuts, ModDetails) ModGuts)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (CgGuts, ModDetails) ModGuts
 -> m (Either (CgGuts, ModDetails) ModGuts))
-> Either (CgGuts, ModDetails) ModGuts
-> m (Either (CgGuts, ModDetails) ModGuts)
forall a b. (a -> b) -> a -> b
$ (CgGuts, ModDetails) -> Either (CgGuts, ModDetails) ModGuts
forall a b. a -> Either a b
Left (CgGuts, ModDetails)
tidy_guts
          else
             Either (CgGuts, ModDetails) ModGuts
-> m (Either (CgGuts, ModDetails) ModGuts)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (CgGuts, ModDetails) ModGuts
 -> m (Either (CgGuts, ModDetails) ModGuts))
-> Either (CgGuts, ModDetails) ModGuts
-> m (Either (CgGuts, ModDetails) ModGuts)
forall a b. (a -> b) -> a -> b
$ ModGuts -> Either (CgGuts, ModDetails) ModGuts
forall a b. b -> Either a b
Right ModGuts
mod_guts

     Maybe ModSummary
Nothing -> FilePath -> m CoreModule
forall a. FilePath -> a
panic "compileToCoreModule: target FilePath not found in\
                           module dependency graph"
  where -- two versions, based on whether we simplify (thus run tidyProgram,
        -- which returns a (CgGuts, ModDetails) pair, or not (in which case
        -- we just have a ModGuts.
        gutsToCoreModule :: SafeHaskellMode
                         -> Either (CgGuts, ModDetails) ModGuts
                         -> CoreModule
        gutsToCoreModule :: SafeHaskellMode
-> Either (CgGuts, ModDetails) ModGuts -> CoreModule
gutsToCoreModule SafeHaskellMode
safe_mode (Left (CgGuts
cg, ModDetails
md)) = CoreModule {
          cm_module :: Module
cm_module = CgGuts -> Module
cg_module CgGuts
cg,
          cm_types :: TypeEnv
cm_types  = ModDetails -> TypeEnv
md_types ModDetails
md,
          cm_binds :: CoreProgram
cm_binds  = CgGuts -> CoreProgram
cg_binds CgGuts
cg,
          cm_safe :: SafeHaskellMode
cm_safe   = SafeHaskellMode
safe_mode
        }
        gutsToCoreModule SafeHaskellMode
safe_mode (Right ModGuts
mg) = CoreModule {
          cm_module :: Module
cm_module  = ModGuts -> Module
mg_module ModGuts
mg,
          cm_types :: TypeEnv
cm_types   = [Var] -> [TyCon] -> [PatSyn] -> [FamInst] -> TypeEnv
typeEnvFromEntities (CoreProgram -> [Var]
forall b. [Bind b] -> [b]
bindersOfBinds (ModGuts -> CoreProgram
mg_binds ModGuts
mg))
                                           (ModGuts -> [TyCon]
mg_tcs ModGuts
mg) (ModGuts -> [PatSyn]
mg_patsyns ModGuts
mg)
                                           (ModGuts -> [FamInst]
mg_fam_insts ModGuts
mg),
          cm_binds :: CoreProgram
cm_binds   = ModGuts -> CoreProgram
mg_binds ModGuts
mg,
          cm_safe :: SafeHaskellMode
cm_safe    = SafeHaskellMode
safe_mode
         }

-- %************************************************************************
-- %*                                                                      *
--             Inspecting the session
-- %*                                                                      *
-- %************************************************************************

-- | Get the module dependency graph.
getModuleGraph :: GhcMonad m => m ModuleGraph -- ToDo: DiGraph ModSummary
getModuleGraph :: forall (m :: * -> *). GhcMonad m => m ModuleGraph
getModuleGraph = (HscEnv -> ModuleGraph) -> m HscEnv -> m ModuleGraph
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM HscEnv -> ModuleGraph
hsc_mod_graph m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession

-- | Return @True@ \<==> module is loaded.
isLoaded :: GhcMonad m => ModuleName -> m Bool
isLoaded :: forall (m :: * -> *). GhcMonad m => ModuleName -> m Bool
isLoaded ModuleName
m = (HscEnv -> m Bool) -> m Bool
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m Bool) -> m Bool) -> (HscEnv -> m Bool) -> m Bool
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env ->
  Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> m Bool) -> Bool -> m Bool
forall a b. (a -> b) -> a -> b
$! Maybe HomeModInfo -> Bool
forall a. Maybe a -> Bool
isJust (HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env) ModuleName
m)

-- | Return the bindings for the current interactive session.
getBindings :: GhcMonad m => m [TyThing]
getBindings :: forall (m :: * -> *). GhcMonad m => m [TyThing]
getBindings = (HscEnv -> m [TyThing]) -> m [TyThing]
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m [TyThing]) -> m [TyThing])
-> (HscEnv -> m [TyThing]) -> m [TyThing]
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env ->
    [TyThing] -> m [TyThing]
forall (m :: * -> *) a. Monad m => a -> m a
return ([TyThing] -> m [TyThing]) -> [TyThing] -> m [TyThing]
forall a b. (a -> b) -> a -> b
$ InteractiveContext -> [TyThing]
icInScopeTTs (InteractiveContext -> [TyThing])
-> InteractiveContext -> [TyThing]
forall a b. (a -> b) -> a -> b
$ HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env

-- | Return the instances for the current interactive session.
getInsts :: GhcMonad m => m ([ClsInst], [FamInst])
getInsts :: forall (m :: * -> *). GhcMonad m => m ([ClsInst], [FamInst])
getInsts = (HscEnv -> m ([ClsInst], [FamInst])) -> m ([ClsInst], [FamInst])
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m ([ClsInst], [FamInst])) -> m ([ClsInst], [FamInst]))
-> (HscEnv -> m ([ClsInst], [FamInst])) -> m ([ClsInst], [FamInst])
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env ->
    ([ClsInst], [FamInst]) -> m ([ClsInst], [FamInst])
forall (m :: * -> *) a. Monad m => a -> m a
return (([ClsInst], [FamInst]) -> m ([ClsInst], [FamInst]))
-> ([ClsInst], [FamInst]) -> m ([ClsInst], [FamInst])
forall a b. (a -> b) -> a -> b
$ InteractiveContext -> ([ClsInst], [FamInst])
ic_instances (HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env)

getPrintUnqual :: GhcMonad m => m PrintUnqualified
getPrintUnqual :: forall (m :: * -> *). GhcMonad m => m PrintUnqualified
getPrintUnqual = (HscEnv -> m PrintUnqualified) -> m PrintUnqualified
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m PrintUnqualified) -> m PrintUnqualified)
-> (HscEnv -> m PrintUnqualified) -> m PrintUnqualified
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env -> do
  PrintUnqualified -> m PrintUnqualified
forall (m :: * -> *) a. Monad m => a -> m a
return (PrintUnqualified -> m PrintUnqualified)
-> PrintUnqualified -> m PrintUnqualified
forall a b. (a -> b) -> a -> b
$ UnitEnv -> InteractiveContext -> PrintUnqualified
icPrintUnqual (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env) (HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env)

-- | Container for information about a 'Module'.
data ModuleInfo = ModuleInfo {
        ModuleInfo -> TypeEnv
minf_type_env  :: TypeEnv,
        ModuleInfo -> Avails
minf_exports   :: [AvailInfo],
        ModuleInfo -> Maybe GlobalRdrEnv
minf_rdr_env   :: Maybe GlobalRdrEnv,   -- Nothing for a compiled/package mod
        ModuleInfo -> [ClsInst]
minf_instances :: [ClsInst],
        ModuleInfo -> Maybe ModIface
minf_iface     :: Maybe ModIface,
        ModuleInfo -> SafeHaskellMode
minf_safe      :: SafeHaskellMode,
        ModuleInfo -> ModBreaks
minf_modBreaks :: ModBreaks
  }
        -- We don't want HomeModInfo here, because a ModuleInfo applies
        -- to package modules too.

-- | Request information about a loaded 'Module'
getModuleInfo :: GhcMonad m => Module -> m (Maybe ModuleInfo)  -- XXX: Maybe X
getModuleInfo :: forall (m :: * -> *). GhcMonad m => Module -> m (Maybe ModuleInfo)
getModuleInfo Module
mdl = (HscEnv -> m (Maybe ModuleInfo)) -> m (Maybe ModuleInfo)
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m (Maybe ModuleInfo)) -> m (Maybe ModuleInfo))
-> (HscEnv -> m (Maybe ModuleInfo)) -> m (Maybe ModuleInfo)
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env -> do
  let mg :: ModuleGraph
mg = HscEnv -> ModuleGraph
hsc_mod_graph HscEnv
hsc_env
  if ModuleGraph -> Module -> Bool
mgElemModule ModuleGraph
mg Module
mdl
        then IO (Maybe ModuleInfo) -> m (Maybe ModuleInfo)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ModuleInfo) -> m (Maybe ModuleInfo))
-> IO (Maybe ModuleInfo) -> m (Maybe ModuleInfo)
forall a b. (a -> b) -> a -> b
$ HscEnv -> Module -> IO (Maybe ModuleInfo)
getHomeModuleInfo HscEnv
hsc_env Module
mdl
        else do
  {- if isHomeModule (hsc_dflags hsc_env) mdl
        then return Nothing
        else -} IO (Maybe ModuleInfo) -> m (Maybe ModuleInfo)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ModuleInfo) -> m (Maybe ModuleInfo))
-> IO (Maybe ModuleInfo) -> m (Maybe ModuleInfo)
forall a b. (a -> b) -> a -> b
$ HscEnv -> Module -> IO (Maybe ModuleInfo)
getPackageModuleInfo HscEnv
hsc_env Module
mdl
   -- ToDo: we don't understand what the following comment means.
   --    (SDM, 19/7/2011)
   -- getPackageModuleInfo will attempt to find the interface, so
   -- we don't want to call it for a home module, just in case there
   -- was a problem loading the module and the interface doesn't
   -- exist... hence the isHomeModule test here.  (ToDo: reinstate)

getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
getPackageModuleInfo HscEnv
hsc_env Module
mdl
  = do  ExternalPackageState
eps <- HscEnv -> IO ExternalPackageState
hscEPS HscEnv
hsc_env
        ModIface
iface <- HscEnv -> Module -> IO ModIface
hscGetModuleInterface HscEnv
hsc_env Module
mdl
        let
            avails :: Avails
avails = ModIface -> Avails
forall (phase :: ModIfacePhase). ModIface_ phase -> Avails
mi_exports ModIface
iface
            pte :: TypeEnv
pte    = ExternalPackageState -> TypeEnv
eps_PTE ExternalPackageState
eps
            tys :: [TyThing]
tys    = [ TyThing
ty | Name
name <- (AvailInfo -> [Name]) -> Avails -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap AvailInfo -> [Name]
availNames Avails
avails,
                            Just TyThing
ty <- [TypeEnv -> Name -> Maybe TyThing
lookupTypeEnv TypeEnv
pte Name
name] ]
        --
        Maybe ModuleInfo -> IO (Maybe ModuleInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleInfo -> Maybe ModuleInfo
forall a. a -> Maybe a
Just (ModuleInfo {
                        minf_type_env :: TypeEnv
minf_type_env  = [TyThing] -> TypeEnv
mkTypeEnv [TyThing]
tys,
                        minf_exports :: Avails
minf_exports   = Avails
avails,
                        minf_rdr_env :: Maybe GlobalRdrEnv
minf_rdr_env   = GlobalRdrEnv -> Maybe GlobalRdrEnv
forall a. a -> Maybe a
Just (GlobalRdrEnv -> Maybe GlobalRdrEnv)
-> GlobalRdrEnv -> Maybe GlobalRdrEnv
forall a b. (a -> b) -> a -> b
$! ModuleName -> Avails -> GlobalRdrEnv
availsToGlobalRdrEnv (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
mdl) Avails
avails,
                        minf_instances :: [ClsInst]
minf_instances = FilePath -> [ClsInst]
forall a. HasCallStack => FilePath -> a
error FilePath
"getModuleInfo: instances for package module unimplemented",
                        minf_iface :: Maybe ModIface
minf_iface     = ModIface -> Maybe ModIface
forall a. a -> Maybe a
Just ModIface
iface,
                        minf_safe :: SafeHaskellMode
minf_safe      = IfaceTrustInfo -> SafeHaskellMode
getSafeMode (IfaceTrustInfo -> SafeHaskellMode)
-> IfaceTrustInfo -> SafeHaskellMode
forall a b. (a -> b) -> a -> b
$ ModIface -> IfaceTrustInfo
forall (phase :: ModIfacePhase). ModIface_ phase -> IfaceTrustInfo
mi_trust ModIface
iface,
                        minf_modBreaks :: ModBreaks
minf_modBreaks = ModBreaks
emptyModBreaks
                }))

availsToGlobalRdrEnv :: ModuleName -> [AvailInfo] -> GlobalRdrEnv
availsToGlobalRdrEnv :: ModuleName -> Avails -> GlobalRdrEnv
availsToGlobalRdrEnv ModuleName
mod_name Avails
avails
  = [GlobalRdrElt] -> GlobalRdrEnv
mkGlobalRdrEnv (Maybe ImportSpec -> Avails -> [GlobalRdrElt]
gresFromAvails (ImportSpec -> Maybe ImportSpec
forall a. a -> Maybe a
Just ImportSpec
imp_spec) Avails
avails)
  where
      -- We're building a GlobalRdrEnv as if the user imported
      -- all the specified modules into the global interactive module
    imp_spec :: ImportSpec
imp_spec = ImpSpec { is_decl :: ImpDeclSpec
is_decl = ImpDeclSpec
decl, is_item :: ImpItemSpec
is_item = ImpItemSpec
ImpAll}
    decl :: ImpDeclSpec
decl = ImpDeclSpec { is_mod :: ModuleName
is_mod = ModuleName
mod_name, is_as :: ModuleName
is_as = ModuleName
mod_name,
                         is_qual :: Bool
is_qual = Bool
False,
                         is_dloc :: SrcSpan
is_dloc = SrcLoc -> SrcSpan
srcLocSpan SrcLoc
interactiveSrcLoc }


getHomeModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
getHomeModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
getHomeModuleInfo HscEnv
hsc_env Module
mdl =
  case HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env) (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
mdl) of
    Maybe HomeModInfo
Nothing  -> Maybe ModuleInfo -> IO (Maybe ModuleInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ModuleInfo
forall a. Maybe a
Nothing
    Just HomeModInfo
hmi -> do
      let details :: ModDetails
details = HomeModInfo -> ModDetails
hm_details HomeModInfo
hmi
          iface :: ModIface
iface   = HomeModInfo -> ModIface
hm_iface HomeModInfo
hmi
      Maybe ModuleInfo -> IO (Maybe ModuleInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleInfo -> Maybe ModuleInfo
forall a. a -> Maybe a
Just (ModuleInfo {
                        minf_type_env :: TypeEnv
minf_type_env  = ModDetails -> TypeEnv
md_types ModDetails
details,
                        minf_exports :: Avails
minf_exports   = ModDetails -> Avails
md_exports ModDetails
details,
                        minf_rdr_env :: Maybe GlobalRdrEnv
minf_rdr_env   = ModIface -> Maybe GlobalRdrEnv
forall (phase :: ModIfacePhase).
ModIface_ phase -> Maybe GlobalRdrEnv
mi_globals (ModIface -> Maybe GlobalRdrEnv) -> ModIface -> Maybe GlobalRdrEnv
forall a b. (a -> b) -> a -> b
$! HomeModInfo -> ModIface
hm_iface HomeModInfo
hmi,
                        minf_instances :: [ClsInst]
minf_instances = ModDetails -> [ClsInst]
md_insts ModDetails
details,
                        minf_iface :: Maybe ModIface
minf_iface     = ModIface -> Maybe ModIface
forall a. a -> Maybe a
Just ModIface
iface,
                        minf_safe :: SafeHaskellMode
minf_safe      = IfaceTrustInfo -> SafeHaskellMode
getSafeMode (IfaceTrustInfo -> SafeHaskellMode)
-> IfaceTrustInfo -> SafeHaskellMode
forall a b. (a -> b) -> a -> b
$ ModIface -> IfaceTrustInfo
forall (phase :: ModIfacePhase). ModIface_ phase -> IfaceTrustInfo
mi_trust ModIface
iface
                       ,minf_modBreaks :: ModBreaks
minf_modBreaks = HomeModInfo -> ModBreaks
getModBreaks HomeModInfo
hmi
                        }))

-- | The list of top-level entities defined in a module
modInfoTyThings :: ModuleInfo -> [TyThing]
modInfoTyThings :: ModuleInfo -> [TyThing]
modInfoTyThings ModuleInfo
minf = TypeEnv -> [TyThing]
typeEnvElts (ModuleInfo -> TypeEnv
minf_type_env ModuleInfo
minf)

modInfoTopLevelScope :: ModuleInfo -> Maybe [Name]
modInfoTopLevelScope :: ModuleInfo -> Maybe [Name]
modInfoTopLevelScope ModuleInfo
minf
  = (GlobalRdrEnv -> [Name]) -> Maybe GlobalRdrEnv -> Maybe [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((GlobalRdrElt -> Name) -> [GlobalRdrElt] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map GlobalRdrElt -> Name
greMangledName ([GlobalRdrElt] -> [Name])
-> (GlobalRdrEnv -> [GlobalRdrElt]) -> GlobalRdrEnv -> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GlobalRdrEnv -> [GlobalRdrElt]
globalRdrEnvElts) (ModuleInfo -> Maybe GlobalRdrEnv
minf_rdr_env ModuleInfo
minf)

modInfoExports :: ModuleInfo -> [Name]
modInfoExports :: ModuleInfo -> [Name]
modInfoExports ModuleInfo
minf = (AvailInfo -> [Name]) -> Avails -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap AvailInfo -> [Name]
availNames (Avails -> [Name]) -> Avails -> [Name]
forall a b. (a -> b) -> a -> b
$! ModuleInfo -> Avails
minf_exports ModuleInfo
minf

modInfoExportsWithSelectors :: ModuleInfo -> [Name]
modInfoExportsWithSelectors :: ModuleInfo -> [Name]
modInfoExportsWithSelectors ModuleInfo
minf = (AvailInfo -> [Name]) -> Avails -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap AvailInfo -> [Name]
availNamesWithSelectors (Avails -> [Name]) -> Avails -> [Name]
forall a b. (a -> b) -> a -> b
$! ModuleInfo -> Avails
minf_exports ModuleInfo
minf

-- | Returns the instances defined by the specified module.
-- Warning: currently unimplemented for package modules.
modInfoInstances :: ModuleInfo -> [ClsInst]
modInfoInstances :: ModuleInfo -> [ClsInst]
modInfoInstances = ModuleInfo -> [ClsInst]
minf_instances

modInfoIsExportedName :: ModuleInfo -> Name -> Bool
modInfoIsExportedName :: ModuleInfo -> Name -> Bool
modInfoIsExportedName ModuleInfo
minf Name
name = Name -> NameSet -> Bool
elemNameSet Name
name (Avails -> NameSet
availsToNameSet (ModuleInfo -> Avails
minf_exports ModuleInfo
minf))

mkPrintUnqualifiedForModule :: GhcMonad m =>
                               ModuleInfo
                            -> m (Maybe PrintUnqualified) -- XXX: returns a Maybe X
mkPrintUnqualifiedForModule :: forall (m :: * -> *).
GhcMonad m =>
ModuleInfo -> m (Maybe PrintUnqualified)
mkPrintUnqualifiedForModule ModuleInfo
minf = (HscEnv -> m (Maybe PrintUnqualified))
-> m (Maybe PrintUnqualified)
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m (Maybe PrintUnqualified))
 -> m (Maybe PrintUnqualified))
-> (HscEnv -> m (Maybe PrintUnqualified))
-> m (Maybe PrintUnqualified)
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env -> do
  let mk_print_unqual :: GlobalRdrEnv -> PrintUnqualified
mk_print_unqual = UnitEnv -> GlobalRdrEnv -> PrintUnqualified
mkPrintUnqualified (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env)
  Maybe PrintUnqualified -> m (Maybe PrintUnqualified)
forall (m :: * -> *) a. Monad m => a -> m a
return ((GlobalRdrEnv -> PrintUnqualified)
-> Maybe GlobalRdrEnv -> Maybe PrintUnqualified
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GlobalRdrEnv -> PrintUnqualified
mk_print_unqual (ModuleInfo -> Maybe GlobalRdrEnv
minf_rdr_env ModuleInfo
minf))

modInfoLookupName :: GhcMonad m =>
                     ModuleInfo -> Name
                  -> m (Maybe TyThing) -- XXX: returns a Maybe X
modInfoLookupName :: forall (m :: * -> *).
GhcMonad m =>
ModuleInfo -> Name -> m (Maybe TyThing)
modInfoLookupName ModuleInfo
minf Name
name = (HscEnv -> m (Maybe TyThing)) -> m (Maybe TyThing)
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m (Maybe TyThing)) -> m (Maybe TyThing))
-> (HscEnv -> m (Maybe TyThing)) -> m (Maybe TyThing)
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env -> do
   case TypeEnv -> Name -> Maybe TyThing
lookupTypeEnv (ModuleInfo -> TypeEnv
minf_type_env ModuleInfo
minf) Name
name of
     Just TyThing
tyThing -> Maybe TyThing -> m (Maybe TyThing)
forall (m :: * -> *) a. Monad m => a -> m a
return (TyThing -> Maybe TyThing
forall a. a -> Maybe a
Just TyThing
tyThing)
     Maybe TyThing
Nothing      -> IO (Maybe TyThing) -> m (Maybe TyThing)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (HscEnv -> Name -> IO (Maybe TyThing)
lookupType HscEnv
hsc_env Name
name)

modInfoIface :: ModuleInfo -> Maybe ModIface
modInfoIface :: ModuleInfo -> Maybe ModIface
modInfoIface = ModuleInfo -> Maybe ModIface
minf_iface

modInfoRdrEnv :: ModuleInfo -> Maybe GlobalRdrEnv
modInfoRdrEnv :: ModuleInfo -> Maybe GlobalRdrEnv
modInfoRdrEnv = ModuleInfo -> Maybe GlobalRdrEnv
minf_rdr_env

-- | Retrieve module safe haskell mode
modInfoSafe :: ModuleInfo -> SafeHaskellMode
modInfoSafe :: ModuleInfo -> SafeHaskellMode
modInfoSafe = ModuleInfo -> SafeHaskellMode
minf_safe

modInfoModBreaks :: ModuleInfo -> ModBreaks
modInfoModBreaks :: ModuleInfo -> ModBreaks
modInfoModBreaks = ModuleInfo -> ModBreaks
minf_modBreaks

isDictonaryId :: Id -> Bool
isDictonaryId :: Var -> Bool
isDictonaryId Var
id
  = case Type -> ([Var], ThetaType, Type)
tcSplitSigmaTy (Var -> Type
idType Var
id) of {
      ([Var]
_tvs, ThetaType
_theta, Type
tau) -> Type -> Bool
isDictTy Type
tau }

-- | Looks up a global name: that is, any top-level name in any
-- visible module.  Unlike 'lookupName', lookupGlobalName does not use
-- the interactive context, and therefore does not require a preceding
-- 'setContext'.
lookupGlobalName :: GhcMonad m => Name -> m (Maybe TyThing)
lookupGlobalName :: forall (m :: * -> *). GhcMonad m => Name -> m (Maybe TyThing)
lookupGlobalName Name
name = (HscEnv -> m (Maybe TyThing)) -> m (Maybe TyThing)
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m (Maybe TyThing)) -> m (Maybe TyThing))
-> (HscEnv -> m (Maybe TyThing)) -> m (Maybe TyThing)
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env -> do
   IO (Maybe TyThing) -> m (Maybe TyThing)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe TyThing) -> m (Maybe TyThing))
-> IO (Maybe TyThing) -> m (Maybe TyThing)
forall a b. (a -> b) -> a -> b
$ HscEnv -> Name -> IO (Maybe TyThing)
lookupType HscEnv
hsc_env Name
name

findGlobalAnns :: (GhcMonad m, Typeable a) => ([Word8] -> a) -> AnnTarget Name -> m [a]
findGlobalAnns :: forall (m :: * -> *) a.
(GhcMonad m, Typeable a) =>
([Word8] -> a) -> AnnTarget Name -> m [a]
findGlobalAnns [Word8] -> a
deserialize AnnTarget Name
target = (HscEnv -> m [a]) -> m [a]
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m [a]) -> m [a]) -> (HscEnv -> m [a]) -> m [a]
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env -> do
    AnnEnv
ann_env <- IO AnnEnv -> m AnnEnv
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO AnnEnv -> m AnnEnv) -> IO AnnEnv -> m AnnEnv
forall a b. (a -> b) -> a -> b
$ HscEnv -> Maybe ModGuts -> IO AnnEnv
prepareAnnotations HscEnv
hsc_env Maybe ModGuts
forall a. Maybe a
Nothing
    [a] -> m [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (([Word8] -> a) -> AnnEnv -> AnnTarget Name -> [a]
forall a.
Typeable a =>
([Word8] -> a) -> AnnEnv -> AnnTarget Name -> [a]
findAnns [Word8] -> a
deserialize AnnEnv
ann_env AnnTarget Name
target)

-- | get the GlobalRdrEnv for a session
getGRE :: GhcMonad m => m GlobalRdrEnv
getGRE :: forall (m :: * -> *). GhcMonad m => m GlobalRdrEnv
getGRE = (HscEnv -> m GlobalRdrEnv) -> m GlobalRdrEnv
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m GlobalRdrEnv) -> m GlobalRdrEnv)
-> (HscEnv -> m GlobalRdrEnv) -> m GlobalRdrEnv
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env-> GlobalRdrEnv -> m GlobalRdrEnv
forall (m :: * -> *) a. Monad m => a -> m a
return (GlobalRdrEnv -> m GlobalRdrEnv) -> GlobalRdrEnv -> m GlobalRdrEnv
forall a b. (a -> b) -> a -> b
$ InteractiveContext -> GlobalRdrEnv
ic_rn_gbl_env (HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env)

-- | Retrieve all type and family instances in the environment, indexed
-- by 'Name'. Each name's lists will contain every instance in which that name
-- is mentioned in the instance head.
getNameToInstancesIndex :: GhcMonad m
  => [Module]        -- ^ visible modules. An orphan instance will be returned
                     -- if it is visible from at least one module in the list.
  -> Maybe [Module]  -- ^ modules to load. If this is not specified, we load
                     -- modules for everything that is in scope unqualified.
  -> m (Messages DecoratedSDoc, Maybe (NameEnv ([ClsInst], [FamInst])))
getNameToInstancesIndex :: forall (m :: * -> *).
GhcMonad m =>
[Module]
-> Maybe [Module]
-> m (Messages DecoratedSDoc,
      Maybe (NameEnv ([ClsInst], [FamInst])))
getNameToInstancesIndex [Module]
visible_mods Maybe [Module]
mods_to_load = do
  HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
  IO (Messages DecoratedSDoc, Maybe (NameEnv ([ClsInst], [FamInst])))
-> m (Messages DecoratedSDoc,
      Maybe (NameEnv ([ClsInst], [FamInst])))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO
   (Messages DecoratedSDoc, Maybe (NameEnv ([ClsInst], [FamInst])))
 -> m (Messages DecoratedSDoc,
       Maybe (NameEnv ([ClsInst], [FamInst]))))
-> IO
     (Messages DecoratedSDoc, Maybe (NameEnv ([ClsInst], [FamInst])))
-> m (Messages DecoratedSDoc,
      Maybe (NameEnv ([ClsInst], [FamInst])))
forall a b. (a -> b) -> a -> b
$ HscEnv
-> TcRn (NameEnv ([ClsInst], [FamInst]))
-> IO
     (Messages DecoratedSDoc, Maybe (NameEnv ([ClsInst], [FamInst])))
forall a. HscEnv -> TcRn a -> IO (Messages DecoratedSDoc, Maybe a)
runTcInteractive HscEnv
hsc_env (TcRn (NameEnv ([ClsInst], [FamInst]))
 -> IO
      (Messages DecoratedSDoc, Maybe (NameEnv ([ClsInst], [FamInst]))))
-> TcRn (NameEnv ([ClsInst], [FamInst]))
-> IO
     (Messages DecoratedSDoc, Maybe (NameEnv ([ClsInst], [FamInst])))
forall a b. (a -> b) -> a -> b
$
    do { case Maybe [Module]
mods_to_load of
           Maybe [Module]
Nothing -> HscEnv -> InteractiveContext -> IOEnv (Env TcGblEnv TcLclEnv) ()
loadUnqualIfaces HscEnv
hsc_env (HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env)
           Just [Module]
mods ->
             let doc :: SDoc
doc = FilePath -> SDoc
text FilePath
"Need interface for reporting instances in scope"
             in IfG () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. IfG a -> TcRn a
initIfaceTcRn (IfG () -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IfG () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ (Module -> IOEnv (Env IfGblEnv ()) ModIface) -> [Module] -> IfG ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (SDoc -> Module -> IOEnv (Env IfGblEnv ()) ModIface
forall lcl. SDoc -> Module -> IfM lcl ModIface
loadSysInterface SDoc
doc) [Module]
mods

       ; InstEnvs {InstEnv
ie_global :: InstEnvs -> InstEnv
ie_global :: InstEnv
ie_global, InstEnv
ie_local :: InstEnvs -> InstEnv
ie_local :: InstEnv
ie_local} <- TcM InstEnvs
tcGetInstEnvs
       ; let visible_mods' :: ModuleSet
visible_mods' = [Module] -> ModuleSet
mkModuleSet [Module]
visible_mods
       ; (FamInstEnv
pkg_fie, FamInstEnv
home_fie) <- TcM (FamInstEnv, FamInstEnv)
tcGetFamInstEnvs
       -- We use Data.Sequence.Seq because we are creating left associated
       -- mappends.
       -- cls_index and fam_index below are adapted from GHC.Tc.Module.lookupInsts
       ; let cls_index :: Map Name (Seq ClsInst)
cls_index = (Seq ClsInst -> Seq ClsInst -> Seq ClsInst)
-> [(Name, Seq ClsInst)] -> Map Name (Seq ClsInst)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith Seq ClsInst -> Seq ClsInst -> Seq ClsInst
forall a. Monoid a => a -> a -> a
mappend
                 [ (Name
n, ClsInst -> Seq ClsInst
forall a. a -> Seq a
Seq.singleton ClsInst
ispec)
                 | ClsInst
ispec <- InstEnv -> [ClsInst]
instEnvElts InstEnv
ie_local [ClsInst] -> [ClsInst] -> [ClsInst]
forall a. [a] -> [a] -> [a]
++ InstEnv -> [ClsInst]
instEnvElts InstEnv
ie_global
                 , ModuleSet -> ClsInst -> Bool
instIsVisible ModuleSet
visible_mods' ClsInst
ispec
                 , Name
n <- NameSet -> [Name]
nameSetElemsStable (NameSet -> [Name]) -> NameSet -> [Name]
forall a b. (a -> b) -> a -> b
$ ClsInst -> NameSet
orphNamesOfClsInst ClsInst
ispec
                 ]
       ; let fam_index :: Map Name (Seq FamInst)
fam_index = (Seq FamInst -> Seq FamInst -> Seq FamInst)
-> [(Name, Seq FamInst)] -> Map Name (Seq FamInst)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith Seq FamInst -> Seq FamInst -> Seq FamInst
forall a. Monoid a => a -> a -> a
mappend
                 [ (Name
n, FamInst -> Seq FamInst
forall a. a -> Seq a
Seq.singleton FamInst
fispec)
                 | FamInst
fispec <- FamInstEnv -> [FamInst]
famInstEnvElts FamInstEnv
home_fie [FamInst] -> [FamInst] -> [FamInst]
forall a. [a] -> [a] -> [a]
++ FamInstEnv -> [FamInst]
famInstEnvElts FamInstEnv
pkg_fie
                 , Name
n <- NameSet -> [Name]
nameSetElemsStable (NameSet -> [Name]) -> NameSet -> [Name]
forall a b. (a -> b) -> a -> b
$ FamInst -> NameSet
orphNamesOfFamInst FamInst
fispec
                 ]
       ; NameEnv ([ClsInst], [FamInst])
-> TcRn (NameEnv ([ClsInst], [FamInst]))
forall (m :: * -> *) a. Monad m => a -> m a
return (NameEnv ([ClsInst], [FamInst])
 -> TcRn (NameEnv ([ClsInst], [FamInst])))
-> NameEnv ([ClsInst], [FamInst])
-> TcRn (NameEnv ([ClsInst], [FamInst]))
forall a b. (a -> b) -> a -> b
$ [(Name, ([ClsInst], [FamInst]))] -> NameEnv ([ClsInst], [FamInst])
forall a. [(Name, a)] -> NameEnv a
mkNameEnv ([(Name, ([ClsInst], [FamInst]))]
 -> NameEnv ([ClsInst], [FamInst]))
-> [(Name, ([ClsInst], [FamInst]))]
-> NameEnv ([ClsInst], [FamInst])
forall a b. (a -> b) -> a -> b
$
           [ (Name
nm, (Seq ClsInst -> [ClsInst]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq ClsInst
clss, Seq FamInst -> [FamInst]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq FamInst
fams))
           | (Name
nm, (Seq ClsInst
clss, Seq FamInst
fams)) <- Map Name (Seq ClsInst, Seq FamInst)
-> [(Name, (Seq ClsInst, Seq FamInst))]
forall k a. Map k a -> [(k, a)]
Map.toList (Map Name (Seq ClsInst, Seq FamInst)
 -> [(Name, (Seq ClsInst, Seq FamInst))])
-> Map Name (Seq ClsInst, Seq FamInst)
-> [(Name, (Seq ClsInst, Seq FamInst))]
forall a b. (a -> b) -> a -> b
$ ((Seq ClsInst, Seq FamInst)
 -> (Seq ClsInst, Seq FamInst) -> (Seq ClsInst, Seq FamInst))
-> Map Name (Seq ClsInst, Seq FamInst)
-> Map Name (Seq ClsInst, Seq FamInst)
-> Map Name (Seq ClsInst, Seq FamInst)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith (Seq ClsInst, Seq FamInst)
-> (Seq ClsInst, Seq FamInst) -> (Seq ClsInst, Seq FamInst)
forall a. Monoid a => a -> a -> a
mappend
               ((Seq ClsInst -> (Seq ClsInst, Seq FamInst))
-> Map Name (Seq ClsInst) -> Map Name (Seq ClsInst, Seq FamInst)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (,Seq FamInst
forall a. Seq a
Seq.empty) Map Name (Seq ClsInst)
cls_index)
               ((Seq FamInst -> (Seq ClsInst, Seq FamInst))
-> Map Name (Seq FamInst) -> Map Name (Seq ClsInst, Seq FamInst)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Seq ClsInst
forall a. Seq a
Seq.empty,) Map Name (Seq FamInst)
fam_index)
           ] }

-- -----------------------------------------------------------------------------

{- ToDo: Move the primary logic here to "GHC.Unit.State"
-- | Return all /external/ modules available in the package database.
-- Modules from the current session (i.e., from the 'HomePackageTable') are
-- not included.  This includes module names which are reexported by packages.
packageDbModules :: GhcMonad m =>
                    Bool  -- ^ Only consider exposed packages.
                 -> m [Module]
packageDbModules only_exposed = do
   dflags <- getSessionDynFlags
   let pkgs = eltsUFM (unitInfoMap (unitState dflags))
   return $
     [ mkModule pid modname
     | p <- pkgs
     , not only_exposed || exposed p
     , let pid = mkUnit p
     , modname <- exposedModules p
               ++ map exportName (reexportedModules p) ]
               -}

-- -----------------------------------------------------------------------------
-- Misc exported utils

dataConType :: DataCon -> Type
dataConType :: DataCon -> Type
dataConType DataCon
dc = Var -> Type
idType (DataCon -> Var
dataConWrapId DataCon
dc)

-- | print a 'NamedThing', adding parentheses if the name is an operator.
pprParenSymName :: NamedThing a => a -> SDoc
pprParenSymName :: forall a. NamedThing a => a -> SDoc
pprParenSymName a
a = OccName -> SDoc -> SDoc
parenSymOcc (a -> OccName
forall a. NamedThing a => a -> OccName
getOccName a
a) (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr (a -> Name
forall a. NamedThing a => a -> Name
getName a
a))

-- ----------------------------------------------------------------------------


-- ToDo:
--   - Data and Typeable instances for HsSyn.

-- ToDo: check for small transformations that happen to the syntax in
-- the typechecker (eg. -e ==> negate e, perhaps for fromIntegral)

-- ToDo: maybe use TH syntax instead of Iface syntax?  There's already a way
-- to get from TyCons, Ids etc. to TH syntax (reify).

-- :browse will use either lm_toplev or inspect lm_interface, depending
-- on whether the module is interpreted or not.


-- Extract the filename, stringbuffer content and dynflags associed to a module
--
-- XXX: Explain pre-conditions
getModuleSourceAndFlags :: GhcMonad m => Module -> m (String, StringBuffer, DynFlags)
getModuleSourceAndFlags :: forall (m :: * -> *).
GhcMonad m =>
Module -> m (FilePath, InputFileBuffer, DynFlags)
getModuleSourceAndFlags Module
mod = do
  ModSummary
m <- ModuleName -> m ModSummary
forall (m :: * -> *). GhcMonad m => ModuleName -> m ModSummary
getModSummary (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
mod)
  case ModLocation -> Maybe FilePath
ml_hs_file (ModLocation -> Maybe FilePath) -> ModLocation -> Maybe FilePath
forall a b. (a -> b) -> a -> b
$ ModSummary -> ModLocation
ms_location ModSummary
m of
    Maybe FilePath
Nothing -> do DynFlags
dflags <- m DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
                  IO (FilePath, InputFileBuffer, DynFlags)
-> m (FilePath, InputFileBuffer, DynFlags)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (FilePath, InputFileBuffer, DynFlags)
 -> m (FilePath, InputFileBuffer, DynFlags))
-> IO (FilePath, InputFileBuffer, DynFlags)
-> m (FilePath, InputFileBuffer, DynFlags)
forall a b. (a -> b) -> a -> b
$ GhcApiError -> IO (FilePath, InputFileBuffer, DynFlags)
forall e a. Exception e => e -> IO a
throwIO (GhcApiError -> IO (FilePath, InputFileBuffer, DynFlags))
-> GhcApiError -> IO (FilePath, InputFileBuffer, DynFlags)
forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> GhcApiError
mkApiErr DynFlags
dflags (FilePath -> SDoc
text FilePath
"No source available for module " SDoc -> SDoc -> SDoc
<+> Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
mod)
    Just FilePath
sourceFile -> do
        InputFileBuffer
source <- IO InputFileBuffer -> m InputFileBuffer
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO InputFileBuffer -> m InputFileBuffer)
-> IO InputFileBuffer -> m InputFileBuffer
forall a b. (a -> b) -> a -> b
$ FilePath -> IO InputFileBuffer
hGetStringBuffer FilePath
sourceFile
        (FilePath, InputFileBuffer, DynFlags)
-> m (FilePath, InputFileBuffer, DynFlags)
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath
sourceFile, InputFileBuffer
source, ModSummary -> DynFlags
ms_hspp_opts ModSummary
m)


-- | Return module source as token stream, including comments.
--
-- The module must be in the module graph and its source must be available.
-- Throws a 'GHC.Driver.Env.SourceError' on parse error.
getTokenStream :: GhcMonad m => Module -> m [Located Token]
getTokenStream :: forall (m :: * -> *). GhcMonad m => Module -> m [Located Token]
getTokenStream Module
mod = do
  (FilePath
sourceFile, InputFileBuffer
source, DynFlags
dflags) <- Module -> m (FilePath, InputFileBuffer, DynFlags)
forall (m :: * -> *).
GhcMonad m =>
Module -> m (FilePath, InputFileBuffer, DynFlags)
getModuleSourceAndFlags Module
mod
  let startLoc :: RealSrcLoc
startLoc = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc (FilePath -> FastString
mkFastString FilePath
sourceFile) Int
1 Int
1
  case ParserOpts
-> InputFileBuffer -> RealSrcLoc -> ParseResult [Located Token]
lexTokenStream (DynFlags -> ParserOpts
initParserOpts DynFlags
dflags) InputFileBuffer
source RealSrcLoc
startLoc of
    POk PState
_ [Located Token]
ts    -> [Located Token] -> m [Located Token]
forall (m :: * -> *) a. Monad m => a -> m a
return [Located Token]
ts
    PFailed PState
pst -> Bag WarnMsg -> m [Located Token]
forall (io :: * -> *) a. MonadIO io => Bag WarnMsg -> io a
throwErrors ((PsError -> WarnMsg) -> Bag PsError -> Bag WarnMsg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PsError -> WarnMsg
pprError (PState -> Bag PsError
getErrorMessages PState
pst))

-- | Give even more information on the source than 'getTokenStream'
-- This function allows reconstructing the source completely with
-- 'showRichTokenStream'.
getRichTokenStream :: GhcMonad m => Module -> m [(Located Token, String)]
getRichTokenStream :: forall (m :: * -> *).
GhcMonad m =>
Module -> m [(Located Token, FilePath)]
getRichTokenStream Module
mod = do
  (FilePath
sourceFile, InputFileBuffer
source, DynFlags
dflags) <- Module -> m (FilePath, InputFileBuffer, DynFlags)
forall (m :: * -> *).
GhcMonad m =>
Module -> m (FilePath, InputFileBuffer, DynFlags)
getModuleSourceAndFlags Module
mod
  let startLoc :: RealSrcLoc
startLoc = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc (FilePath -> FastString
mkFastString FilePath
sourceFile) Int
1 Int
1
  case ParserOpts
-> InputFileBuffer -> RealSrcLoc -> ParseResult [Located Token]
lexTokenStream (DynFlags -> ParserOpts
initParserOpts DynFlags
dflags) InputFileBuffer
source RealSrcLoc
startLoc of
    POk PState
_ [Located Token]
ts    -> [(Located Token, FilePath)] -> m [(Located Token, FilePath)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Located Token, FilePath)] -> m [(Located Token, FilePath)])
-> [(Located Token, FilePath)] -> m [(Located Token, FilePath)]
forall a b. (a -> b) -> a -> b
$ RealSrcLoc
-> InputFileBuffer
-> [Located Token]
-> [(Located Token, FilePath)]
addSourceToTokens RealSrcLoc
startLoc InputFileBuffer
source [Located Token]
ts
    PFailed PState
pst -> Bag WarnMsg -> m [(Located Token, FilePath)]
forall (io :: * -> *) a. MonadIO io => Bag WarnMsg -> io a
throwErrors ((PsError -> WarnMsg) -> Bag PsError -> Bag WarnMsg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PsError -> WarnMsg
pprError (PState -> Bag PsError
getErrorMessages PState
pst))

-- | Given a source location and a StringBuffer corresponding to this
-- location, return a rich token stream with the source associated to the
-- tokens.
addSourceToTokens :: RealSrcLoc -> StringBuffer -> [Located Token]
                  -> [(Located Token, String)]
addSourceToTokens :: RealSrcLoc
-> InputFileBuffer
-> [Located Token]
-> [(Located Token, FilePath)]
addSourceToTokens RealSrcLoc
_ InputFileBuffer
_ [] = []
addSourceToTokens RealSrcLoc
loc InputFileBuffer
buf (t :: Located Token
t@(L SrcSpan
span Token
_) : [Located Token]
ts)
    = case SrcSpan
span of
      UnhelpfulSpan UnhelpfulSpanReason
_ -> (Located Token
t,FilePath
"") (Located Token, FilePath)
-> [(Located Token, FilePath)] -> [(Located Token, FilePath)]
forall a. a -> [a] -> [a]
: RealSrcLoc
-> InputFileBuffer
-> [Located Token]
-> [(Located Token, FilePath)]
addSourceToTokens RealSrcLoc
loc InputFileBuffer
buf [Located Token]
ts
      RealSrcSpan RealSrcSpan
s Maybe BufSpan
_ -> (Located Token
t,FilePath
str) (Located Token, FilePath)
-> [(Located Token, FilePath)] -> [(Located Token, FilePath)]
forall a. a -> [a] -> [a]
: RealSrcLoc
-> InputFileBuffer
-> [Located Token]
-> [(Located Token, FilePath)]
addSourceToTokens RealSrcLoc
newLoc InputFileBuffer
newBuf [Located Token]
ts
        where
          (RealSrcLoc
newLoc, InputFileBuffer
newBuf, FilePath
str) = FilePath
-> RealSrcLoc
-> InputFileBuffer
-> (RealSrcLoc, InputFileBuffer, FilePath)
go FilePath
"" RealSrcLoc
loc InputFileBuffer
buf
          start :: RealSrcLoc
start = RealSrcSpan -> RealSrcLoc
realSrcSpanStart RealSrcSpan
s
          end :: RealSrcLoc
end = RealSrcSpan -> RealSrcLoc
realSrcSpanEnd RealSrcSpan
s
          go :: FilePath
-> RealSrcLoc
-> InputFileBuffer
-> (RealSrcLoc, InputFileBuffer, FilePath)
go FilePath
acc RealSrcLoc
loc InputFileBuffer
buf | RealSrcLoc
loc RealSrcLoc -> RealSrcLoc -> Bool
forall a. Ord a => a -> a -> Bool
< RealSrcLoc
start = FilePath
-> RealSrcLoc
-> InputFileBuffer
-> (RealSrcLoc, InputFileBuffer, FilePath)
go FilePath
acc RealSrcLoc
nLoc InputFileBuffer
nBuf
                         | RealSrcLoc
start RealSrcLoc -> RealSrcLoc -> Bool
forall a. Ord a => a -> a -> Bool
<= RealSrcLoc
loc Bool -> Bool -> Bool
&& RealSrcLoc
loc RealSrcLoc -> RealSrcLoc -> Bool
forall a. Ord a => a -> a -> Bool
< RealSrcLoc
end = FilePath
-> RealSrcLoc
-> InputFileBuffer
-> (RealSrcLoc, InputFileBuffer, FilePath)
go (Char
chChar -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:FilePath
acc) RealSrcLoc
nLoc InputFileBuffer
nBuf
                         | Bool
otherwise = (RealSrcLoc
loc, InputFileBuffer
buf, FilePath -> FilePath
forall a. [a] -> [a]
reverse FilePath
acc)
              where (Char
ch, InputFileBuffer
nBuf) = InputFileBuffer -> (Char, InputFileBuffer)
nextChar InputFileBuffer
buf
                    nLoc :: RealSrcLoc
nLoc = RealSrcLoc -> Char -> RealSrcLoc
advanceSrcLoc RealSrcLoc
loc Char
ch


-- | Take a rich token stream such as produced from 'getRichTokenStream' and
-- return source code almost identical to the original code (except for
-- insignificant whitespace.)
showRichTokenStream :: [(Located Token, String)] -> String
showRichTokenStream :: [(Located Token, FilePath)] -> FilePath
showRichTokenStream [(Located Token, FilePath)]
ts = RealSrcLoc -> [(Located Token, FilePath)] -> FilePath -> FilePath
forall {e}.
RealSrcLoc
-> [(GenLocated SrcSpan e, FilePath)] -> FilePath -> FilePath
go RealSrcLoc
startLoc [(Located Token, FilePath)]
ts FilePath
""
    where sourceFile :: FastString
sourceFile = [SrcSpan] -> FastString
getFile ([SrcSpan] -> FastString) -> [SrcSpan] -> FastString
forall a b. (a -> b) -> a -> b
$ ((Located Token, FilePath) -> SrcSpan)
-> [(Located Token, FilePath)] -> [SrcSpan]
forall a b. (a -> b) -> [a] -> [b]
map (Located Token -> SrcSpan
forall l e. GenLocated l e -> l
getLoc (Located Token -> SrcSpan)
-> ((Located Token, FilePath) -> Located Token)
-> (Located Token, FilePath)
-> SrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Located Token, FilePath) -> Located Token
forall a b. (a, b) -> a
fst) [(Located Token, FilePath)]
ts
          getFile :: [SrcSpan] -> FastString
getFile [] = FilePath -> FastString
forall a. FilePath -> a
panic FilePath
"showRichTokenStream: No source file found"
          getFile (UnhelpfulSpan UnhelpfulSpanReason
_ : [SrcSpan]
xs) = [SrcSpan] -> FastString
getFile [SrcSpan]
xs
          getFile (RealSrcSpan RealSrcSpan
s Maybe BufSpan
_ : [SrcSpan]
_) = RealSrcSpan -> FastString
srcSpanFile RealSrcSpan
s
          startLoc :: RealSrcLoc
startLoc = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc FastString
sourceFile Int
1 Int
1
          go :: RealSrcLoc
-> [(GenLocated SrcSpan e, FilePath)] -> FilePath -> FilePath
go RealSrcLoc
_ [] = FilePath -> FilePath
forall a. a -> a
id
          go RealSrcLoc
loc ((L SrcSpan
span e
_, FilePath
str):[(GenLocated SrcSpan e, FilePath)]
ts)
              = case SrcSpan
span of
                UnhelpfulSpan UnhelpfulSpanReason
_ -> RealSrcLoc
-> [(GenLocated SrcSpan e, FilePath)] -> FilePath -> FilePath
go RealSrcLoc
loc [(GenLocated SrcSpan e, FilePath)]
ts
                RealSrcSpan RealSrcSpan
s Maybe BufSpan
_
                 | Int
locLine Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
tokLine -> ((Int -> Char -> FilePath
forall a. Int -> a -> [a]
replicate (Int
tokCol Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
locCol) Char
' ') FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++)
                                       (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath
str FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++)
                                       (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealSrcLoc
-> [(GenLocated SrcSpan e, FilePath)] -> FilePath -> FilePath
go RealSrcLoc
tokEnd [(GenLocated SrcSpan e, FilePath)]
ts
                 | Bool
otherwise -> ((Int -> Char -> FilePath
forall a. Int -> a -> [a]
replicate (Int
tokLine Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
locLine) Char
'\n') FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++)
                               (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int -> Char -> FilePath
forall a. Int -> a -> [a]
replicate (Int
tokCol Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Char
' ') FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++)
                              (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath
str FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++)
                              (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealSrcLoc
-> [(GenLocated SrcSpan e, FilePath)] -> FilePath -> FilePath
go RealSrcLoc
tokEnd [(GenLocated SrcSpan e, FilePath)]
ts
                  where (Int
locLine, Int
locCol) = (RealSrcLoc -> Int
srcLocLine RealSrcLoc
loc, RealSrcLoc -> Int
srcLocCol RealSrcLoc
loc)
                        (Int
tokLine, Int
tokCol) = (RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
s, RealSrcSpan -> Int
srcSpanStartCol RealSrcSpan
s)
                        tokEnd :: RealSrcLoc
tokEnd = RealSrcSpan -> RealSrcLoc
realSrcSpanEnd RealSrcSpan
s

-- -----------------------------------------------------------------------------
-- Interactive evaluation

-- | Takes a 'ModuleName' and possibly a 'UnitId', and consults the
-- filesystem and package database to find the corresponding 'Module',
-- using the algorithm that is used for an @import@ declaration.
findModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module
findModule :: forall (m :: * -> *).
GhcMonad m =>
ModuleName -> Maybe FastString -> m Module
findModule ModuleName
mod_name Maybe FastString
maybe_pkg = (HscEnv -> m Module) -> m Module
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m Module) -> m Module)
-> (HscEnv -> m Module) -> m Module
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env -> do
  let dflags :: DynFlags
dflags     = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
      home_unit :: HomeUnit
home_unit  = HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env
  case Maybe FastString
maybe_pkg of
    Just FastString
pkg | Bool -> Bool
not (HomeUnit -> Unit -> Bool
isHomeUnit HomeUnit
home_unit (FastString -> Unit
fsToUnit FastString
pkg)) Bool -> Bool -> Bool
&& FastString
pkg FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
/= FilePath -> FastString
fsLit FilePath
"this" -> IO Module -> m Module
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Module -> m Module) -> IO Module -> m Module
forall a b. (a -> b) -> a -> b
$ do
      FindResult
res <- HscEnv -> ModuleName -> Maybe FastString -> IO FindResult
findImportedModule HscEnv
hsc_env ModuleName
mod_name Maybe FastString
maybe_pkg
      case FindResult
res of
        Found ModLocation
_ Module
m -> Module -> IO Module
forall (m :: * -> *) a. Monad m => a -> m a
return Module
m
        FindResult
err       -> WarnMsg -> IO Module
forall (io :: * -> *) a. MonadIO io => WarnMsg -> io a
throwOneError (WarnMsg -> IO Module) -> WarnMsg -> IO Module
forall a b. (a -> b) -> a -> b
$ HscEnv -> SrcSpan -> ModuleName -> FindResult -> WarnMsg
noModError HscEnv
hsc_env SrcSpan
noSrcSpan ModuleName
mod_name FindResult
err
    Maybe FastString
_otherwise -> do
      Maybe Module
home <- ModuleName -> m (Maybe Module)
forall (m :: * -> *). GhcMonad m => ModuleName -> m (Maybe Module)
lookupLoadedHomeModule ModuleName
mod_name
      case Maybe Module
home of
        Just Module
m  -> Module -> m Module
forall (m :: * -> *) a. Monad m => a -> m a
return Module
m
        Maybe Module
Nothing -> IO Module -> m Module
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Module -> m Module) -> IO Module -> m Module
forall a b. (a -> b) -> a -> b
$ do
           FindResult
res <- HscEnv -> ModuleName -> Maybe FastString -> IO FindResult
findImportedModule HscEnv
hsc_env ModuleName
mod_name Maybe FastString
maybe_pkg
           case FindResult
res of
             Found ModLocation
loc Module
m | Bool -> Bool
not (HomeUnit -> Module -> Bool
isHomeModule HomeUnit
home_unit Module
m) -> Module -> IO Module
forall (m :: * -> *) a. Monad m => a -> m a
return Module
m
                         | Bool
otherwise -> DynFlags -> Module -> ModLocation -> IO Module
forall a. DynFlags -> Module -> ModLocation -> IO a
modNotLoadedError DynFlags
dflags Module
m ModLocation
loc
             FindResult
err -> WarnMsg -> IO Module
forall (io :: * -> *) a. MonadIO io => WarnMsg -> io a
throwOneError (WarnMsg -> IO Module) -> WarnMsg -> IO Module
forall a b. (a -> b) -> a -> b
$ HscEnv -> SrcSpan -> ModuleName -> FindResult -> WarnMsg
noModError HscEnv
hsc_env SrcSpan
noSrcSpan ModuleName
mod_name FindResult
err

modNotLoadedError :: DynFlags -> Module -> ModLocation -> IO a
modNotLoadedError :: forall a. DynFlags -> Module -> ModLocation -> IO a
modNotLoadedError DynFlags
dflags Module
m ModLocation
loc = GhcException -> IO a
forall a. GhcException -> IO a
throwGhcExceptionIO (GhcException -> IO a) -> GhcException -> IO a
forall a b. (a -> b) -> a -> b
$ FilePath -> GhcException
CmdLineError (FilePath -> GhcException) -> FilePath -> GhcException
forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> FilePath
showSDoc DynFlags
dflags (SDoc -> FilePath) -> SDoc -> FilePath
forall a b. (a -> b) -> a -> b
$
   FilePath -> SDoc
text FilePath
"module is not loaded:" SDoc -> SDoc -> SDoc
<+>
   SDoc -> SDoc
quotes (ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
m)) SDoc -> SDoc -> SDoc
<+>
   SDoc -> SDoc
parens (FilePath -> SDoc
text (FilePath -> Maybe FilePath -> FilePath
forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"modNotLoadedError" (ModLocation -> Maybe FilePath
ml_hs_file ModLocation
loc)))

-- | Like 'findModule', but differs slightly when the module refers to
-- a source file, and the file has not been loaded via 'load'.  In
-- this case, 'findModule' will throw an error (module not loaded),
-- but 'lookupModule' will check to see whether the module can also be
-- found in a package, and if so, that package 'Module' will be
-- returned.  If not, the usual module-not-found error will be thrown.
--
lookupModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module
lookupModule :: forall (m :: * -> *).
GhcMonad m =>
ModuleName -> Maybe FastString -> m Module
lookupModule ModuleName
mod_name (Just FastString
pkg) = ModuleName -> Maybe FastString -> m Module
forall (m :: * -> *).
GhcMonad m =>
ModuleName -> Maybe FastString -> m Module
findModule ModuleName
mod_name (FastString -> Maybe FastString
forall a. a -> Maybe a
Just FastString
pkg)
lookupModule ModuleName
mod_name Maybe FastString
Nothing = (HscEnv -> m Module) -> m Module
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m Module) -> m Module)
-> (HscEnv -> m Module) -> m Module
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env -> do
  Maybe Module
home <- ModuleName -> m (Maybe Module)
forall (m :: * -> *). GhcMonad m => ModuleName -> m (Maybe Module)
lookupLoadedHomeModule ModuleName
mod_name
  case Maybe Module
home of
    Just Module
m  -> Module -> m Module
forall (m :: * -> *) a. Monad m => a -> m a
return Module
m
    Maybe Module
Nothing -> IO Module -> m Module
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Module -> m Module) -> IO Module -> m Module
forall a b. (a -> b) -> a -> b
$ do
      FindResult
res <- HscEnv -> ModuleName -> Maybe FastString -> IO FindResult
findExposedPackageModule HscEnv
hsc_env ModuleName
mod_name Maybe FastString
forall a. Maybe a
Nothing
      case FindResult
res of
        Found ModLocation
_ Module
m -> Module -> IO Module
forall (m :: * -> *) a. Monad m => a -> m a
return Module
m
        FindResult
err       -> WarnMsg -> IO Module
forall (io :: * -> *) a. MonadIO io => WarnMsg -> io a
throwOneError (WarnMsg -> IO Module) -> WarnMsg -> IO Module
forall a b. (a -> b) -> a -> b
$ HscEnv -> SrcSpan -> ModuleName -> FindResult -> WarnMsg
noModError HscEnv
hsc_env SrcSpan
noSrcSpan ModuleName
mod_name FindResult
err

lookupLoadedHomeModule :: GhcMonad m => ModuleName -> m (Maybe Module)
lookupLoadedHomeModule :: forall (m :: * -> *). GhcMonad m => ModuleName -> m (Maybe Module)
lookupLoadedHomeModule ModuleName
mod_name = (HscEnv -> m (Maybe Module)) -> m (Maybe Module)
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m (Maybe Module)) -> m (Maybe Module))
-> (HscEnv -> m (Maybe Module)) -> m (Maybe Module)
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env ->
  case HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env) ModuleName
mod_name of
    Just HomeModInfo
mod_info      -> Maybe Module -> m (Maybe Module)
forall (m :: * -> *) a. Monad m => a -> m a
return (Module -> Maybe Module
forall a. a -> Maybe a
Just (ModIface -> Module
forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module (HomeModInfo -> ModIface
hm_iface HomeModInfo
mod_info)))
    Maybe HomeModInfo
_not_a_home_module -> Maybe Module -> m (Maybe Module)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Module
forall a. Maybe a
Nothing

-- | Check that a module is safe to import (according to Safe Haskell).
--
-- We return True to indicate the import is safe and False otherwise
-- although in the False case an error may be thrown first.
isModuleTrusted :: GhcMonad m => Module -> m Bool
isModuleTrusted :: forall (m :: * -> *). GhcMonad m => Module -> m Bool
isModuleTrusted Module
m = (HscEnv -> m Bool) -> m Bool
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m Bool) -> m Bool) -> (HscEnv -> m Bool) -> m Bool
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env ->
    IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ HscEnv -> Module -> SrcSpan -> IO Bool
hscCheckSafe HscEnv
hsc_env Module
m SrcSpan
noSrcSpan

-- | Return if a module is trusted and the pkgs it depends on to be trusted.
moduleTrustReqs :: GhcMonad m => Module -> m (Bool, Set UnitId)
moduleTrustReqs :: forall (m :: * -> *). GhcMonad m => Module -> m (Bool, Set UnitId)
moduleTrustReqs Module
m = (HscEnv -> m (Bool, Set UnitId)) -> m (Bool, Set UnitId)
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m (Bool, Set UnitId)) -> m (Bool, Set UnitId))
-> (HscEnv -> m (Bool, Set UnitId)) -> m (Bool, Set UnitId)
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env ->
    IO (Bool, Set UnitId) -> m (Bool, Set UnitId)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Bool, Set UnitId) -> m (Bool, Set UnitId))
-> IO (Bool, Set UnitId) -> m (Bool, Set UnitId)
forall a b. (a -> b) -> a -> b
$ HscEnv -> Module -> SrcSpan -> IO (Bool, Set UnitId)
hscGetSafe HscEnv
hsc_env Module
m SrcSpan
noSrcSpan

-- | Set the monad GHCi lifts user statements into.
--
-- Checks that a type (in string form) is an instance of the
-- @GHC.GHCi.GHCiSandboxIO@ type class. Sets it to be the GHCi monad if it is,
-- throws an error otherwise.
setGHCiMonad :: GhcMonad m => String -> m ()
setGHCiMonad :: forall (m :: * -> *). GhcMonad m => FilePath -> m ()
setGHCiMonad FilePath
name = (HscEnv -> m ()) -> m ()
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m ()) -> m ()) -> (HscEnv -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env -> do
    Name
ty <- IO Name -> m Name
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Name -> m Name) -> IO Name -> m Name
forall a b. (a -> b) -> a -> b
$ HscEnv -> FilePath -> IO Name
hscIsGHCiMonad HscEnv
hsc_env FilePath
name
    (HscEnv -> HscEnv) -> m ()
forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession ((HscEnv -> HscEnv) -> m ()) -> (HscEnv -> HscEnv) -> m ()
forall a b. (a -> b) -> a -> b
$ \HscEnv
s ->
        let ic :: InteractiveContext
ic = (HscEnv -> InteractiveContext
hsc_IC HscEnv
s) { ic_monad :: Name
ic_monad = Name
ty }
        in HscEnv
s { hsc_IC :: InteractiveContext
hsc_IC = InteractiveContext
ic }

-- | Get the monad GHCi lifts user statements into.
getGHCiMonad :: GhcMonad m => m Name
getGHCiMonad :: forall (m :: * -> *). GhcMonad m => m Name
getGHCiMonad = (HscEnv -> Name) -> m HscEnv -> m Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (InteractiveContext -> Name
ic_monad (InteractiveContext -> Name)
-> (HscEnv -> InteractiveContext) -> HscEnv -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv -> InteractiveContext
hsc_IC) m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession

getHistorySpan :: GhcMonad m => History -> m SrcSpan
getHistorySpan :: forall (m :: * -> *). GhcMonad m => History -> m SrcSpan
getHistorySpan History
h = (HscEnv -> m SrcSpan) -> m SrcSpan
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m SrcSpan) -> m SrcSpan)
-> (HscEnv -> m SrcSpan) -> m SrcSpan
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env ->
    SrcSpan -> m SrcSpan
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> m SrcSpan) -> SrcSpan -> m SrcSpan
forall a b. (a -> b) -> a -> b
$ HscEnv -> History -> SrcSpan
GHC.Runtime.Eval.getHistorySpan HscEnv
hsc_env History
h

obtainTermFromVal :: GhcMonad m => Int ->  Bool -> Type -> a -> m Term
obtainTermFromVal :: forall (m :: * -> *) a.
GhcMonad m =>
Int -> Bool -> Type -> a -> m Term
obtainTermFromVal Int
bound Bool
force Type
ty a
a = (HscEnv -> m Term) -> m Term
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m Term) -> m Term) -> (HscEnv -> m Term) -> m Term
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env ->
    IO Term -> m Term
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Term -> m Term) -> IO Term -> m Term
forall a b. (a -> b) -> a -> b
$ HscEnv -> Int -> Bool -> Type -> a -> IO Term
forall a. HscEnv -> Int -> Bool -> Type -> a -> IO Term
GHC.Runtime.Eval.obtainTermFromVal HscEnv
hsc_env Int
bound Bool
force Type
ty a
a

obtainTermFromId :: GhcMonad m => Int -> Bool -> Id -> m Term
obtainTermFromId :: forall (m :: * -> *). GhcMonad m => Int -> Bool -> Var -> m Term
obtainTermFromId Int
bound Bool
force Var
id = (HscEnv -> m Term) -> m Term
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m Term) -> m Term) -> (HscEnv -> m Term) -> m Term
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env ->
    IO Term -> m Term
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Term -> m Term) -> IO Term -> m Term
forall a b. (a -> b) -> a -> b
$ HscEnv -> Int -> Bool -> Var -> IO Term
GHC.Runtime.Eval.obtainTermFromId HscEnv
hsc_env Int
bound Bool
force Var
id


-- | Returns the 'TyThing' for a 'Name'.  The 'Name' may refer to any
-- entity known to GHC, including 'Name's defined using 'runStmt'.
lookupName :: GhcMonad m => Name -> m (Maybe TyThing)
lookupName :: forall (m :: * -> *). GhcMonad m => Name -> m (Maybe TyThing)
lookupName Name
name =
     (HscEnv -> m (Maybe TyThing)) -> m (Maybe TyThing)
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m (Maybe TyThing)) -> m (Maybe TyThing))
-> (HscEnv -> m (Maybe TyThing)) -> m (Maybe TyThing)
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env ->
       IO (Maybe TyThing) -> m (Maybe TyThing)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe TyThing) -> m (Maybe TyThing))
-> IO (Maybe TyThing) -> m (Maybe TyThing)
forall a b. (a -> b) -> a -> b
$ HscEnv -> Name -> IO (Maybe TyThing)
hscTcRcLookupName HscEnv
hsc_env Name
name

-- -----------------------------------------------------------------------------
-- Pure API

-- | A pure interface to the module parser.
--
parser :: String         -- ^ Haskell module source text (full Unicode is supported)
       -> DynFlags       -- ^ the flags
       -> FilePath       -- ^ the filename (for source locations)
       -> (WarningMessages, Either ErrorMessages (Located HsModule))

parser :: FilePath
-> DynFlags
-> FilePath
-> (Bag WarnMsg, Either (Bag WarnMsg) ParsedSource)
parser FilePath
str DynFlags
dflags FilePath
filename =
   let
       loc :: RealSrcLoc
loc  = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc (FilePath -> FastString
mkFastString FilePath
filename) Int
1 Int
1
       buf :: InputFileBuffer
buf  = FilePath -> InputFileBuffer
stringToStringBuffer FilePath
str
   in
   case P ParsedSource -> PState -> ParseResult ParsedSource
forall a. P a -> PState -> ParseResult a
unP P ParsedSource
Parser.parseModule (ParserOpts -> InputFileBuffer -> RealSrcLoc -> PState
initParserState (DynFlags -> ParserOpts
initParserOpts DynFlags
dflags) InputFileBuffer
buf RealSrcLoc
loc) of

     PFailed PState
pst ->
         let (Bag PsWarning
warns,Bag PsError
errs) = PState -> (Bag PsWarning, Bag PsError)
getMessages PState
pst in
         ((PsWarning -> WarnMsg) -> Bag PsWarning -> Bag WarnMsg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PsWarning -> WarnMsg
pprWarning Bag PsWarning
warns, Bag WarnMsg -> Either (Bag WarnMsg) ParsedSource
forall a b. a -> Either a b
Left ((PsError -> WarnMsg) -> Bag PsError -> Bag WarnMsg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PsError -> WarnMsg
pprError Bag PsError
errs))

     POk PState
pst ParsedSource
rdr_module ->
         let (Bag PsWarning
warns,Bag PsError
_) = PState -> (Bag PsWarning, Bag PsError)
getMessages PState
pst in
         ((PsWarning -> WarnMsg) -> Bag PsWarning -> Bag WarnMsg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PsWarning -> WarnMsg
pprWarning Bag PsWarning
warns, ParsedSource -> Either (Bag WarnMsg) ParsedSource
forall a b. b -> Either a b
Right ParsedSource
rdr_module)

-- -----------------------------------------------------------------------------
-- | Find the package environment (if one exists)
--
-- We interpret the package environment as a set of package flags; to be
-- specific, if we find a package environment file like
--
-- > clear-package-db
-- > global-package-db
-- > package-db blah/package.conf.d
-- > package-id id1
-- > package-id id2
--
-- we interpret this as
--
-- > [ -hide-all-packages
-- > , -clear-package-db
-- > , -global-package-db
-- > , -package-db blah/package.conf.d
-- > , -package-id id1
-- > , -package-id id2
-- > ]
--
-- There's also an older syntax alias for package-id, which is just an
-- unadorned package id
--
-- > id1
-- > id2
--
interpretPackageEnv :: Logger -> DynFlags -> IO DynFlags
interpretPackageEnv :: Logger -> DynFlags -> IO DynFlags
interpretPackageEnv Logger
logger DynFlags
dflags = do
    Maybe FilePath
mPkgEnv <- MaybeT IO FilePath -> IO (Maybe FilePath)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT IO FilePath -> IO (Maybe FilePath))
-> MaybeT IO FilePath -> IO (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ [MaybeT IO FilePath] -> MaybeT IO FilePath
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ([MaybeT IO FilePath] -> MaybeT IO FilePath)
-> [MaybeT IO FilePath] -> MaybeT IO FilePath
forall a b. (a -> b) -> a -> b
$ [
                   MaybeT IO FilePath
getCmdLineArg MaybeT IO FilePath
-> (FilePath -> MaybeT IO FilePath) -> MaybeT IO FilePath
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \FilePath
env -> [MaybeT IO FilePath] -> MaybeT IO FilePath
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum [
                       FilePath -> MaybeT IO FilePath
probeNullEnv FilePath
env
                     , FilePath -> MaybeT IO FilePath
probeEnvFile FilePath
env
                     , FilePath -> MaybeT IO FilePath
probeEnvName FilePath
env
                     , FilePath -> MaybeT IO FilePath
forall a. FilePath -> MaybeT IO a
cmdLineError FilePath
env
                     ]
                 , MaybeT IO FilePath
getEnvVar MaybeT IO FilePath
-> (FilePath -> MaybeT IO FilePath) -> MaybeT IO FilePath
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \FilePath
env -> [MaybeT IO FilePath] -> MaybeT IO FilePath
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum [
                       FilePath -> MaybeT IO FilePath
probeNullEnv FilePath
env
                     , FilePath -> MaybeT IO FilePath
probeEnvFile FilePath
env
                     , FilePath -> MaybeT IO FilePath
probeEnvName FilePath
env
                     , FilePath -> MaybeT IO FilePath
forall a. FilePath -> MaybeT IO a
envError     FilePath
env
                     ]
                 , MaybeT IO ()
notIfHideAllPackages MaybeT IO () -> MaybeT IO FilePath -> MaybeT IO FilePath
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [MaybeT IO FilePath] -> MaybeT IO FilePath
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum [
                       MaybeT IO FilePath
findLocalEnvFile MaybeT IO FilePath
-> (FilePath -> MaybeT IO FilePath) -> MaybeT IO FilePath
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FilePath -> MaybeT IO FilePath
probeEnvFile
                     , FilePath -> MaybeT IO FilePath
probeEnvName FilePath
defaultEnvName
                     ]
                 ]
    case Maybe FilePath
mPkgEnv of
      Maybe FilePath
Nothing ->
        -- No environment found. Leave DynFlags unchanged.
        DynFlags -> IO DynFlags
forall (m :: * -> *) a. Monad m => a -> m a
return DynFlags
dflags
      Just FilePath
"-" -> do
        -- Explicitly disabled environment file. Leave DynFlags unchanged.
        DynFlags -> IO DynFlags
forall (m :: * -> *) a. Monad m => a -> m a
return DynFlags
dflags
      Just FilePath
envfile -> do
        FilePath
content <- FilePath -> IO FilePath
readFile FilePath
envfile
        Logger -> DynFlags -> SDoc -> IO ()
compilationProgressMsg Logger
logger DynFlags
dflags (FilePath -> SDoc
text FilePath
"Loaded package environment from " SDoc -> SDoc -> SDoc
<> FilePath -> SDoc
text FilePath
envfile)
        let ((Errs, Warns, ())
_, DynFlags
dflags') = CmdLineP DynFlags (Errs, Warns, ())
-> DynFlags -> ((Errs, Warns, ()), DynFlags)
forall s a. CmdLineP s a -> s -> (a, s)
runCmdLine (EwM (CmdLineP DynFlags) () -> CmdLineP DynFlags (Errs, Warns, ())
forall (m :: * -> *) a. EwM m a -> m (Errs, Warns, a)
runEwM (FilePath -> FilePath -> EwM (CmdLineP DynFlags) ()
setFlagsFromEnvFile FilePath
envfile FilePath
content)) DynFlags
dflags

        DynFlags -> IO DynFlags
forall (m :: * -> *) a. Monad m => a -> m a
return DynFlags
dflags'
  where
    -- Loading environments (by name or by location)

    archOS :: ArchOS
archOS = Platform -> ArchOS
platformArchOS (DynFlags -> Platform
targetPlatform DynFlags
dflags)

    namedEnvPath :: String -> MaybeT IO FilePath
    namedEnvPath :: FilePath -> MaybeT IO FilePath
namedEnvPath FilePath
name = do
     FilePath
appdir <- FilePath -> ArchOS -> MaybeT IO FilePath
versionedAppDir (DynFlags -> FilePath
programName DynFlags
dflags) ArchOS
archOS
     FilePath -> MaybeT IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> MaybeT IO FilePath) -> FilePath -> MaybeT IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
appdir FilePath -> FilePath -> FilePath
</> FilePath
"environments" FilePath -> FilePath -> FilePath
</> FilePath
name

    probeEnvName :: String -> MaybeT IO FilePath
    probeEnvName :: FilePath -> MaybeT IO FilePath
probeEnvName FilePath
name = FilePath -> MaybeT IO FilePath
probeEnvFile (FilePath -> MaybeT IO FilePath)
-> MaybeT IO FilePath -> MaybeT IO FilePath
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> MaybeT IO FilePath
namedEnvPath FilePath
name

    probeEnvFile :: FilePath -> MaybeT IO FilePath
    probeEnvFile :: FilePath -> MaybeT IO FilePath
probeEnvFile FilePath
path = do
      Bool -> MaybeT IO ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> MaybeT IO ()) -> MaybeT IO Bool -> MaybeT IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO Bool -> MaybeT IO Bool
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
liftMaybeT (FilePath -> IO Bool
doesFileExist FilePath
path)
      FilePath -> MaybeT IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
path

    probeNullEnv :: FilePath -> MaybeT IO FilePath
    probeNullEnv :: FilePath -> MaybeT IO FilePath
probeNullEnv FilePath
"-" = FilePath -> MaybeT IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
"-"
    probeNullEnv FilePath
_   = MaybeT IO FilePath
forall (m :: * -> *) a. MonadPlus m => m a
mzero

    -- Various ways to define which environment to use

    getCmdLineArg :: MaybeT IO String
    getCmdLineArg :: MaybeT IO FilePath
getCmdLineArg = IO (Maybe FilePath) -> MaybeT IO FilePath
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe FilePath) -> MaybeT IO FilePath)
-> IO (Maybe FilePath) -> MaybeT IO FilePath
forall a b. (a -> b) -> a -> b
$ Maybe FilePath -> IO (Maybe FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe FilePath -> IO (Maybe FilePath))
-> Maybe FilePath -> IO (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ DynFlags -> Maybe FilePath
packageEnv DynFlags
dflags

    getEnvVar :: MaybeT IO String
    getEnvVar :: MaybeT IO FilePath
getEnvVar = do
      Either IOError FilePath
mvar <- IO (Either IOError FilePath) -> MaybeT IO (Either IOError FilePath)
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
liftMaybeT (IO (Either IOError FilePath)
 -> MaybeT IO (Either IOError FilePath))
-> IO (Either IOError FilePath)
-> MaybeT IO (Either IOError FilePath)
forall a b. (a -> b) -> a -> b
$ IO FilePath -> IO (Either IOError FilePath)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
MC.try (IO FilePath -> IO (Either IOError FilePath))
-> IO FilePath -> IO (Either IOError FilePath)
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FilePath
getEnv FilePath
"GHC_ENVIRONMENT"
      case Either IOError FilePath
mvar of
        Right FilePath
var -> FilePath -> MaybeT IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
var
        Left IOError
err  -> if IOError -> Bool
isDoesNotExistError IOError
err then MaybeT IO FilePath
forall (m :: * -> *) a. MonadPlus m => m a
mzero
                                                else IO FilePath -> MaybeT IO FilePath
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
liftMaybeT (IO FilePath -> MaybeT IO FilePath)
-> IO FilePath -> MaybeT IO FilePath
forall a b. (a -> b) -> a -> b
$ IOError -> IO FilePath
forall e a. Exception e => e -> IO a
throwIO IOError
err

    notIfHideAllPackages :: MaybeT IO ()
    notIfHideAllPackages :: MaybeT IO ()
notIfHideAllPackages =
      Bool -> MaybeT IO ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_HideAllPackages DynFlags
dflags))

    defaultEnvName :: String
    defaultEnvName :: FilePath
defaultEnvName = FilePath
"default"

    -- e.g. .ghc.environment.x86_64-linux-7.6.3
    localEnvFileName :: FilePath
    localEnvFileName :: FilePath
localEnvFileName = FilePath
".ghc.environment" FilePath -> FilePath -> FilePath
<.> ArchOS -> FilePath
versionedFilePath ArchOS
archOS

    -- Search for an env file, starting in the current dir and looking upwards.
    -- Fail if we get to the users home dir or the filesystem root. That is,
    -- we don't look for an env file in the user's home dir. The user-wide
    -- env lives in ghc's versionedAppDir/environments/default
    findLocalEnvFile :: MaybeT IO FilePath
    findLocalEnvFile :: MaybeT IO FilePath
findLocalEnvFile = do
        FilePath
curdir  <- IO FilePath -> MaybeT IO FilePath
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
liftMaybeT IO FilePath
getCurrentDirectory
        FilePath
homedir <- IO FilePath -> MaybeT IO FilePath
forall a. IO a -> MaybeT IO a
tryMaybeT IO FilePath
getHomeDirectory
        let probe :: FilePath -> MaybeT IO FilePath
probe FilePath
dir | FilePath -> Bool
isDrive FilePath
dir Bool -> Bool -> Bool
|| FilePath
dir FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
homedir
                      = MaybeT IO FilePath
forall (m :: * -> *) a. MonadPlus m => m a
mzero
            probe FilePath
dir = do
              let file :: FilePath
file = FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
localEnvFileName
              Bool
exists <- IO Bool -> MaybeT IO Bool
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
liftMaybeT (FilePath -> IO Bool
doesFileExist FilePath
file)
              if Bool
exists
                then FilePath -> MaybeT IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
file
                else FilePath -> MaybeT IO FilePath
probe (FilePath -> FilePath
takeDirectory FilePath
dir)
        FilePath -> MaybeT IO FilePath
probe FilePath
curdir

    -- Error reporting

    cmdLineError :: String -> MaybeT IO a
    cmdLineError :: forall a. FilePath -> MaybeT IO a
cmdLineError FilePath
env = IO a -> MaybeT IO a
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
liftMaybeT (IO a -> MaybeT IO a)
-> (FilePath -> IO a) -> FilePath -> MaybeT IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GhcException -> IO a
forall a. GhcException -> IO a
throwGhcExceptionIO (GhcException -> IO a)
-> (FilePath -> GhcException) -> FilePath -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> GhcException
CmdLineError (FilePath -> MaybeT IO a) -> FilePath -> MaybeT IO a
forall a b. (a -> b) -> a -> b
$
      FilePath
"Package environment " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
env FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" not found"

    envError :: String -> MaybeT IO a
    envError :: forall a. FilePath -> MaybeT IO a
envError FilePath
env = IO a -> MaybeT IO a
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
liftMaybeT (IO a -> MaybeT IO a)
-> (FilePath -> IO a) -> FilePath -> MaybeT IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GhcException -> IO a
forall a. GhcException -> IO a
throwGhcExceptionIO (GhcException -> IO a)
-> (FilePath -> GhcException) -> FilePath -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> GhcException
CmdLineError (FilePath -> MaybeT IO a) -> FilePath -> MaybeT IO a
forall a b. (a -> b) -> a -> b
$
         FilePath
"Package environment "
      FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
env
      FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" (specified in GHC_ENVIRONMENT) not found"

-- | An error thrown if the GHC API is used in an incorrect fashion.
newtype GhcApiError = GhcApiError String

instance Show GhcApiError where
  show :: GhcApiError -> FilePath
show (GhcApiError FilePath
msg) = FilePath
msg

instance Exception GhcApiError

mkApiErr :: DynFlags -> SDoc -> GhcApiError
mkApiErr :: DynFlags -> SDoc -> GhcApiError
mkApiErr DynFlags
dflags SDoc
msg = FilePath -> GhcApiError
GhcApiError (DynFlags -> SDoc -> FilePath
showSDoc DynFlags
dflags SDoc
msg)