{-# 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,
        gcatch, gbracket, gfinally,
        printException,
        handleSourceError,
        needsTemplateHaskellOrQQ,

        -- * Flags and settings
        DynFlags(..), GeneralFlag(..), Severity(..), HscTarget(..), gopt,
        GhcMode(..), GhcLink(..), defaultObjectTarget,
        parseDynamicFlags,
        getSessionDynFlags, setSessionDynFlags,
        getProgramDynFlags, setProgramDynFlags, setLogAction,
        getInteractiveDynFlags, setInteractiveDynFlags,

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

        -- * Loading\/compiling the program
        depanal,
        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(..),
        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,
        InteractiveEval.compileExpr, dynCompileExpr,
        ForeignHValue,
        compileExprRemote, compileParsedExprRemote,

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

        -- ** Other
        runTcInteractive,   -- Desired by some clients (Trac #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(breakInfo_number, breakInfo_module),
        InteractiveEval.back,
        InteractiveEval.forward,

        -- * Abstract syntax elements

        -- ** Packages
        UnitId,

        -- ** Modules
        Module, mkModule, pprModule, moduleName, moduleUnitId,
        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,
        isBottomingId, 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,
        dataConSig, dataConType, dataConTyCon, dataConFieldLabels,
        dataConIsInfix, isVanillaDataCon, dataConUserType,
        dataConSrcBangs,
        StrictnessMark(..), isMarkedStrict,

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

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

        FamInst,

        -- ** Types and Kinds
        Type, splitForAllTys, funResultTy,
        pprParendType, pprTypeApp,
        Kind,
        PredType,
        ThetaType, pprForAll, pprThetaArrowTy,

        -- ** Entities
        TyThing(..),

        -- ** Syntax
        module HsSyn, -- 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,

        -- *** Constructing Located
        noLoc, mkGeneralLocated,

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

        -- ** HasSrcSpan
        HasSrcSpan(..), SrcSpanLess, dL, cL,

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

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

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

        -- * Pure interface to the parser
        parser,

        -- * API Annotations
        ApiAnns,AnnKeywordId(..),AnnotationComment(..),
        getAnnotation, getAndRemoveAnnotation,
        getAnnotationComments, getAndRemoveAnnotationComments,
        unicodeAnn,

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

{-
 ToDo:

  * inline bits of HscMain here to simplify layering: hscTcExpr, hscStmt.
-}

#include "HsVersions.h"

import GhcPrelude hiding (init)

import ByteCodeTypes
import InteractiveEval
import InteractiveEvalTypes
import GHCi
import GHCi.RemoteTypes

import PprTyThing       ( pprFamInst )
import HscMain
import GhcMake
import DriverPipeline   ( compileOne' )
import GhcMonad
import TcRnMonad        ( finalSafeMode, fixSafeInstances, initIfaceTcRn )
import LoadIface        ( loadSysInterface )
import TcRnTypes
import Packages
import NameSet
import RdrName
import HsSyn
import Type     hiding( typeKind )
import TcType           hiding( typeKind )
import Id
import TysPrim          ( alphaTyVars )
import TyCon
import Class
import DataCon
import Name             hiding ( varName )
import Avail
import InstEnv
import FamInstEnv ( FamInst )
import SrcLoc
import CoreSyn
import TidyPgm
import DriverPhases     ( Phase(..), isHaskellSrcFilename )
import Finder
import HscTypes
import CmdLineParser
import DynFlags hiding (WarnReason(..))
import SysTools
import SysTools.BaseDir
import Annotations
import Module
import Panic
import Platform
import Bag              ( listToBag, unitBag )
import ErrUtils
import MonadUtils
import Util
import StringBuffer
import Outputable
import BasicTypes
import Maybes           ( expectJust )
import FastString
import qualified Parser
import Lexer
import ApiAnnotation
import qualified GHC.LanguageExtensions as LangExt
import NameEnv
import CoreFVs          ( orphNamesOfFamInst )
import FamInstEnv       ( famInstEnvElts )
import TcRnDriver
import Inst
import FamInst
import FileCleanup

import Data.Foldable
import qualified Data.Map.Strict as Map
import Data.Set (Set)
import qualified Data.Sequence as Seq
import System.Directory ( doesFileExist )
import Data.Maybe
import Data.Time
import Data.Typeable    ( Typeable )
import Data.Word        ( Word8 )
import Control.Monad
import System.Exit      ( exitWith, ExitCode(..) )
import Exception
import Data.IORef
import System.FilePath


-- %************************************************************************
-- %*                                                                      *
--             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 :: FatalMessager -> FlushOut -> m a -> m a
defaultErrorHandler fm :: FatalMessager
fm (FlushOut flushOut :: IO ()
flushOut) inner :: 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.
(ExceptionMonad m, Exception e) =>
(e -> m a) -> m a -> m a
ghandle (\exception :: 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 IOException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exception of
                -- an IO exception probably isn't our fault, so don't panic
                Just (IOException
ioe :: IOException) ->
                  FatalMessager -> FatalMessager
fatalErrorMsg'' FatalMessager
fm (IOException -> String
forall a. Show a => a -> String
show IOException
ioe)
                _ -> case SomeException -> Maybe AsyncException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exception of
                     Just 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 StackOverflow ->
                         FatalMessager -> FatalMessager
fatalErrorMsg'' FatalMessager
fm "stack overflow: use +RTS -K<size> to increase it"
                     _ -> 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
                          _ ->
                              FatalMessager -> FatalMessager
fatalErrorMsg'' FatalMessager
fm
                                  (GhcException -> String
forall a. Show a => a -> String
show (String -> GhcException
Panic (SomeException -> String
forall a. Show a => a -> String
show SomeException
exception)))
           ExitCode -> IO a
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure 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
            (\ge :: 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 _ -> ExitCode -> IO a
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure 1)
                     _ -> do FatalMessager -> FatalMessager
fatalErrorMsg'' FatalMessager
fm (GhcException -> String
forall a. Show a => a -> String
show GhcException
ge)
                             ExitCode -> IO a
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure 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 :: DynFlags -> m a -> m a
defaultCleanupHandler _ m :: 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. ExceptionMonad m => m a -> m b -> m a
`gonException` 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 :: Maybe String -> Ghc a -> IO a
runGhc mb_top_dir :: Maybe String
mb_top_dir ghc :: Ghc a
ghc = do
  IORef HscEnv
ref <- HscEnv -> IO (IORef HscEnv)
forall a. a -> IO (IORef a)
newIORef (String -> HscEnv
forall a. String -> a
panic "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, MonadIO 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 String -> Ghc ()
forall (m :: * -> *). GhcMonad m => Maybe String -> m ()
initGhcMonad Maybe String
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 :: Maybe String -> GhcT m a -> m a
runGhcT mb_top_dir :: Maybe String
mb_top_dir ghct :: 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 (String -> HscEnv
forall a. String -> a
panic "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, MonadIO 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 String -> GhcT m ()
forall (m :: * -> *). GhcMonad m => Maybe String -> m ()
initGhcMonad Maybe String
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 :: m a -> m a
withCleanupSession ghc :: m a
ghc = m a
ghc m a -> m () -> m a
forall (m :: * -> *) a b. ExceptionMonad m => m a -> m b -> m a
`gfinally` 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
      IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
          DynFlags -> IO ()
cleanTempFiles DynFlags
dflags
          DynFlags -> IO ()
cleanTempDirs DynFlags
dflags
          HscEnv -> IO ()
stopIServ HscEnv
hsc_env -- shut down the IServ
          --  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 :: Maybe String -> m ()
initGhcMonad mb_top_dir :: Maybe String
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 { String
top_dir <- Maybe String -> IO String
findTopDir Maybe String
mb_top_dir
                   ; Settings
mySettings <- String -> IO Settings
initSysTools String
top_dir
                   ; LlvmConfig
myLlvmConfig <- String -> IO LlvmConfig
initLlvmConfig String
top_dir
                   ; DynFlags
dflags <- DynFlags -> IO DynFlags
initDynFlags (Settings -> LlvmConfig -> DynFlags
defaultDynFlags Settings
mySettings LlvmConfig
myLlvmConfig)
                   ; DynFlags -> IO ()
forall (m :: * -> *). MonadIO m => DynFlags -> m ()
checkBrokenTablesNextToCode DynFlags
dflags
                   ; DynFlags -> IO ()
setUnsafeGlobalDynFlags DynFlags
dflags
                      -- c.f. DynFlags.parseDynamicFlagsFull, which
                      -- creates DynFlags and sets the UnsafeGlobalDynFlags
                   ; DynFlags -> IO HscEnv
newHscEnv DynFlags
dflags }
       ; 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://ghc.haskell.org/trac/ghc/ticket/4210#comment:29
checkBrokenTablesNextToCode :: MonadIO m => DynFlags -> m ()
checkBrokenTablesNextToCode :: DynFlags -> m ()
checkBrokenTablesNextToCode dflags :: DynFlags
dflags
  = do { Bool
broken <- DynFlags -> m Bool
forall (m :: * -> *). MonadIO m => DynFlags -> m Bool
checkBrokenTablesNextToCode' 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 => String -> m a
fail "unsupported linker"
              }
       }
  where
    invalidLdErr :: SDoc
invalidLdErr = String -> SDoc
text "Tables-next-to-code not supported on ARM" SDoc -> SDoc -> SDoc
<+>
                   String -> SDoc
text "when using binutils ld (please see:" SDoc -> SDoc -> SDoc
<+>
                   String -> SDoc
text "https://sourceware.org/bugzilla/show_bug.cgi?id=16177)"

checkBrokenTablesNextToCode' :: MonadIO m => DynFlags -> m Bool
checkBrokenTablesNextToCode' :: DynFlags -> m Bool
checkBrokenTablesNextToCode' dflags :: 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 -> [Way] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` DynFlags -> [Way]
ways DynFlags
dflags  = Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  | Bool -> Bool
not (DynFlags -> Bool
tablesNextToCode DynFlags
dflags) = 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
$ DynFlags -> IO LinkerInfo
getLinkerInfo DynFlags
dflags
    case LinkerInfo
linkerInfo of
      GnuLD _  -> Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
      _        -> 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


-- %************************************************************************
-- %*                                                                      *
--             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).
--
-- Returns a list of new packages that may need to be linked in using
-- the dynamic linker (see 'linkPackages') as a result of new package
-- flags.  If you are not doing linking or doing static linking, you
-- can ignore the list of packages returned.
--
setSessionDynFlags :: GhcMonad m => DynFlags -> m [InstalledUnitId]
setSessionDynFlags :: DynFlags -> m [InstalledUnitId]
setSessionDynFlags dflags :: DynFlags
dflags = do
  DynFlags
dflags' <- DynFlags -> m DynFlags
forall (m :: * -> *). MonadIO m => DynFlags -> m DynFlags
checkNewDynFlags DynFlags
dflags
  (dflags'' :: DynFlags
dflags'', preload :: [InstalledUnitId]
preload) <- IO (DynFlags, [InstalledUnitId]) -> m (DynFlags, [InstalledUnitId])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (DynFlags, [InstalledUnitId])
 -> m (DynFlags, [InstalledUnitId]))
-> IO (DynFlags, [InstalledUnitId])
-> m (DynFlags, [InstalledUnitId])
forall a b. (a -> b) -> a -> b
$ DynFlags -> IO (DynFlags, [InstalledUnitId])
initPackages DynFlags
dflags'
  (HscEnv -> HscEnv) -> m ()
forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession ((HscEnv -> HscEnv) -> m ()) -> (HscEnv -> HscEnv) -> m ()
forall a b. (a -> b) -> a -> b
$ \h :: 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'' } }
  m ()
forall (m :: * -> *). GhcMonad m => m ()
invalidateModSummaryCache
  [InstalledUnitId] -> m [InstalledUnitId]
forall (m :: * -> *) a. Monad m => a -> m a
return [InstalledUnitId]
preload

-- | Sets the program 'DynFlags'.  Note: this invalidates the internal
-- cached module graph, causing more work to be done the next time
-- 'load' is called.
setProgramDynFlags :: GhcMonad m => DynFlags -> m [InstalledUnitId]
setProgramDynFlags :: DynFlags -> m [InstalledUnitId]
setProgramDynFlags dflags :: DynFlags
dflags = Bool -> DynFlags -> m [InstalledUnitId]
forall (m :: * -> *).
GhcMonad m =>
Bool -> DynFlags -> m [InstalledUnitId]
setProgramDynFlags_ Bool
True DynFlags
dflags

-- | Set the action taken when the compiler produces a message.  This
-- can also be accomplished using 'setProgramDynFlags', but using
-- 'setLogAction' avoids invalidating the cached module graph.
setLogAction :: GhcMonad m => LogAction -> m ()
setLogAction :: LogAction -> m ()
setLogAction action :: LogAction
action = do
  DynFlags
dflags' <- m DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getProgramDynFlags
  m [InstalledUnitId] -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m [InstalledUnitId] -> m ()) -> m [InstalledUnitId] -> m ()
forall a b. (a -> b) -> a -> b
$ Bool -> DynFlags -> m [InstalledUnitId]
forall (m :: * -> *).
GhcMonad m =>
Bool -> DynFlags -> m [InstalledUnitId]
setProgramDynFlags_ Bool
False (DynFlags -> m [InstalledUnitId])
-> DynFlags -> m [InstalledUnitId]
forall a b. (a -> b) -> a -> b
$
    DynFlags
dflags' { log_action :: LogAction
log_action = LogAction
action }

setProgramDynFlags_ :: GhcMonad m => Bool -> DynFlags -> m [InstalledUnitId]
setProgramDynFlags_ :: Bool -> DynFlags -> m [InstalledUnitId]
setProgramDynFlags_ invalidate_needed :: Bool
invalidate_needed dflags :: DynFlags
dflags = do
  DynFlags
dflags' <- DynFlags -> m DynFlags
forall (m :: * -> *). MonadIO m => DynFlags -> m DynFlags
checkNewDynFlags DynFlags
dflags
  DynFlags
dflags_prev <- m DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getProgramDynFlags
  (dflags'' :: DynFlags
dflags'', preload :: [InstalledUnitId]
preload) <-
    if (DynFlags -> DynFlags -> Bool
packageFlagsChanged DynFlags
dflags_prev DynFlags
dflags')
       then IO (DynFlags, [InstalledUnitId]) -> m (DynFlags, [InstalledUnitId])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (DynFlags, [InstalledUnitId])
 -> m (DynFlags, [InstalledUnitId]))
-> IO (DynFlags, [InstalledUnitId])
-> m (DynFlags, [InstalledUnitId])
forall a b. (a -> b) -> a -> b
$ DynFlags -> IO (DynFlags, [InstalledUnitId])
initPackages DynFlags
dflags'
       else (DynFlags, [InstalledUnitId]) -> m (DynFlags, [InstalledUnitId])
forall (m :: * -> *) a. Monad m => a -> m a
return (DynFlags
dflags', [])
  (HscEnv -> HscEnv) -> m ()
forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession ((HscEnv -> HscEnv) -> m ()) -> (HscEnv -> HscEnv) -> m ()
forall a b. (a -> b) -> a -> b
$ \h :: HscEnv
h -> HscEnv
h{ hsc_dflags :: DynFlags
hsc_dflags = DynFlags
dflags'' }
  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
  [InstalledUnitId] -> m [InstalledUnitId]
forall (m :: * -> *) a. Monad m => a -> m a
return [InstalledUnitId]
preload


-- 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
-- recopmile a module, we'll have re-summarised the module and have a
-- correct ModSummary.
--
invalidateModSummaryCache :: GhcMonad m => m ()
invalidateModSummaryCache :: 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
$ \h :: 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 ms :: ModSummary
ms = ModSummary
ms { ms_hs_date :: UTCTime
ms_hs_date = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (-1) (ModSummary -> UTCTime
ms_hs_date ModSummary
ms) }

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

-- | Set the 'DynFlags' used to evaluate interactive expressions.
-- Note: this cannot be used for changes to packages.  Use
-- 'setSessionDynFlags', or 'setProgramDynFlags' and then copy the
-- 'pkgState' into the interactive @DynFlags@.
setInteractiveDynFlags :: GhcMonad m => DynFlags -> m ()
setInteractiveDynFlags :: DynFlags -> m ()
setInteractiveDynFlags dflags :: DynFlags
dflags = do
  DynFlags
dflags' <- DynFlags -> m DynFlags
forall (m :: * -> *). MonadIO m => DynFlags -> m DynFlags
checkNewDynFlags DynFlags
dflags
  DynFlags
dflags'' <- DynFlags -> m DynFlags
forall (m :: * -> *). MonadIO m => DynFlags -> m DynFlags
checkNewInteractiveDynFlags DynFlags
dflags'
  (HscEnv -> HscEnv) -> m ()
forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession ((HscEnv -> HscEnv) -> m ()) -> (HscEnv -> HscEnv) -> m ()
forall a b. (a -> b) -> a -> b
$ \h :: HscEnv
h -> HscEnv
h{ hsc_IC :: InteractiveContext
hsc_IC = (HscEnv -> InteractiveContext
hsc_IC HscEnv
h) { ic_dflags :: DynFlags
ic_dflags = DynFlags
dflags'' }}

-- | Get the 'DynFlags' used to evaluate interactive expressions.
getInteractiveDynFlags :: GhcMonad m => m DynFlags
getInteractiveDynFlags :: 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
$ \h :: 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 =>
                     DynFlags -> [Located String]
                  -> m (DynFlags, [Located String], [Warn])
parseDynamicFlags :: DynFlags
-> [Located String] -> m (DynFlags, [Located String], [Warn])
parseDynamicFlags = DynFlags
-> [Located String] -> m (DynFlags, [Located String], [Warn])
forall (m :: * -> *).
MonadIO m =>
DynFlags
-> [Located String] -> m (DynFlags, [Located String], [Warn])
parseDynamicFlagsCmdLine

-- | 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 => DynFlags -> m DynFlags
checkNewDynFlags :: DynFlags -> m DynFlags
checkNewDynFlags dflags :: DynFlags
dflags = do
  -- See Note [DynFlags consistency]
  let (dflags' :: DynFlags
dflags', warnings :: [Located String]
warnings) = DynFlags -> (DynFlags, [Located String])
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
$ DynFlags -> [Warn] -> IO ()
handleFlagWarnings DynFlags
dflags ((Located String -> Warn) -> [Located String] -> [Warn]
forall a b. (a -> b) -> [a] -> [b]
map (WarnReason -> Located String -> Warn
Warn WarnReason
NoReason) [Located String]
warnings)
  DynFlags -> m DynFlags
forall (m :: * -> *) a. Monad m => a -> m a
return DynFlags
dflags'

checkNewInteractiveDynFlags :: MonadIO m => DynFlags -> m DynFlags
checkNewInteractiveDynFlags :: DynFlags -> m DynFlags
checkNewInteractiveDynFlags dflags0 :: DynFlags
dflags0 = do
  -- We currently don't support use of StaticPointers in expressions entered on
  -- the REPL. See #12356.
  DynFlags
dflags1 <-
      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
$ DynFlags -> Bag WarnMsg -> IO ()
printOrThrowWarnings DynFlags
dflags0 (Bag WarnMsg -> IO ()) -> Bag WarnMsg -> IO ()
forall a b. (a -> b) -> a -> b
$ [WarnMsg] -> Bag WarnMsg
forall a. [a] -> Bag a
listToBag
                [DynFlags -> SrcSpan -> SDoc -> WarnMsg
mkPlainWarnMsg DynFlags
dflags0 SrcSpan
interactiveSrcSpan
                 (SDoc -> WarnMsg) -> SDoc -> WarnMsg
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text "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
  DynFlags -> m DynFlags
forall (m :: * -> *) a. Monad m => a -> m a
return DynFlags
dflags1


-- %************************************************************************
-- %*                                                                      *
--             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 :: [Target] -> m ()
setTargets targets :: [Target]
targets = (HscEnv -> HscEnv) -> m ()
forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession (\h :: HscEnv
h -> HscEnv
h{ hsc_targets :: [Target]
hsc_targets = [Target]
targets })

-- | Returns the current set of targets
getTargets :: GhcMonad m => m [Target]
getTargets :: 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 :: Target -> m ()
addTarget target :: Target
target
  = (HscEnv -> HscEnv) -> m ()
forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession (\h :: 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 :: TargetId -> m ()
removeTarget target_id :: TargetId
target_id
  = (HscEnv -> HscEnv) -> m ()
forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession (\h :: HscEnv
h -> HscEnv
h{ hsc_targets :: [Target]
hsc_targets = [Target] -> [Target]
filter (HscEnv -> [Target]
hsc_targets HscEnv
h) })
  where
   filter :: [Target] -> [Target]
filter targets :: [Target]
targets = [ Target
t | t :: Target
t@(Target id :: TargetId
id _ _) <- [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 :: String -> Maybe Phase -> m Target
guessTarget str :: String
str (Just phase :: Phase
phase)
   = Target -> m Target
forall (m :: * -> *) a. Monad m => a -> m a
return (TargetId -> Bool -> Maybe (InputFileBuffer, UTCTime) -> Target
Target (String -> Maybe Phase -> TargetId
TargetFile String
str (Phase -> Maybe Phase
forall a. a -> Maybe a
Just Phase
phase)) Bool
True Maybe (InputFileBuffer, UTCTime)
forall a. Maybe a
Nothing)
guessTarget str :: String
str Nothing
   | String -> Bool
isHaskellSrcFilename String
file
   = Target -> m Target
forall (m :: * -> *) a. Monad m => a -> m a
return (TargetId -> Target
target (String -> Maybe Phase -> TargetId
TargetFile String
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
$ String -> IO Bool
doesFileExist String
hs_file
        if Bool
exists
           then Target -> m Target
forall (m :: * -> *) a. Monad m => a -> m a
return (TargetId -> Target
target (String -> Maybe Phase -> TargetId
TargetFile String
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
$ String -> IO Bool
doesFileExist String
lhs_file
        if Bool
exists
           then Target -> m Target
forall (m :: * -> *) a. Monad m => a -> m a
return (TargetId -> Target
target (String -> Maybe Phase -> TargetId
TargetFile String
lhs_file Maybe Phase
forall a. Maybe a
Nothing))
           else do
        if String -> Bool
looksLikeModuleName String
file
           then Target -> m Target
forall (m :: * -> *) a. Monad m => a -> m a
return (TargetId -> Target
target (ModuleName -> TargetId
TargetModule (String -> ModuleName
mkModuleName String
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
                 (String -> GhcException
ProgramError (DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (SDoc -> String) -> SDoc -> String
forall a b. (a -> b) -> a -> b
$
                 String -> SDoc
text "target" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (String -> SDoc
text String
file) SDoc -> SDoc -> SDoc
<+>
                 String -> SDoc
text "is not a module name or a source file"))
     where
         (file :: String
file,obj_allowed :: Bool
obj_allowed)
                | '*':rest :: String
rest <- String
str = (String
rest, Bool
False)
                | Bool
otherwise       = (String
str,  Bool
True)

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

         target :: TargetId -> Target
target tid :: 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 :: 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 -> [String]
pm_extra_src_files :: [FilePath]
               , ParsedModule -> ApiAnns
pm_annotations :: ApiAnns }
               -- See Note [Api annotations] in ApiAnnotation.hs

instance ParsedMod ParsedModule where
  modSummary :: ParsedModule -> ModSummary
modSummary m :: ParsedModule
m    = ParsedModule -> ModSummary
pm_mod_summary ParsedModule
m
  parsedSource :: ParsedModule -> ParsedSource
parsedSource m :: 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 m :: TypecheckedModule
m   = ParsedModule -> ModSummary
forall m. ParsedMod m => m -> ModSummary
modSummary (TypecheckedModule -> ParsedModule
tm_parsed_module TypecheckedModule
m)
  parsedSource :: TypecheckedModule -> ParsedSource
parsedSource m :: 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 m :: TypecheckedModule
m     = TypecheckedModule -> Maybe RenamedSource
tm_renamed_source TypecheckedModule
m
  typecheckedSource :: TypecheckedModule -> TypecheckedSource
typecheckedSource m :: TypecheckedModule
m = TypecheckedModule -> TypecheckedSource
tm_typechecked_source TypecheckedModule
m
  moduleInfo :: TypecheckedModule -> ModuleInfo
moduleInfo m :: TypecheckedModule
m        = TypecheckedModule -> ModuleInfo
tm_checked_module_info TypecheckedModule
m
  tm_internals :: TypecheckedModule -> (TcGblEnv, ModDetails)
tm_internals m :: 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 m :: DesugaredModule
m   = TypecheckedModule -> ModSummary
forall m. ParsedMod m => m -> ModSummary
modSummary (DesugaredModule -> TypecheckedModule
dm_typechecked_module DesugaredModule
m)
  parsedSource :: DesugaredModule -> ParsedSource
parsedSource m :: 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 m :: DesugaredModule
m     = TypecheckedModule -> Maybe RenamedSource
forall m. TypecheckedMod m => m -> Maybe RenamedSource
renamedSource (DesugaredModule -> TypecheckedModule
dm_typechecked_module DesugaredModule
m)
  typecheckedSource :: DesugaredModule -> TypecheckedSource
typecheckedSource m :: DesugaredModule
m = TypecheckedModule -> TypecheckedSource
forall m. TypecheckedMod m => m -> TypecheckedSource
typecheckedSource (DesugaredModule -> TypecheckedModule
dm_typechecked_module DesugaredModule
m)
  moduleInfo :: DesugaredModule -> ModuleInfo
moduleInfo m :: 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 m :: DesugaredModule
m      = TypecheckedModule -> (TcGblEnv, ModDetails)
tm_internals_ (DesugaredModule -> TypecheckedModule
dm_typechecked_module DesugaredModule
m)

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

type ParsedSource      = Located (HsModule GhcPs)
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 :: ModuleName -> m ModSummary
getModSummary mod :: 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
                      , Bool -> Bool
not (ModSummary -> Bool
isBootSummary ModSummary
ms) ]
   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 (String -> SDoc
text "Module not part of module graph")
     [ms :: ModSummary
ms] -> ModSummary -> m ModSummary
forall (m :: * -> *) a. Monad m => a -> m a
return ModSummary
ms
     multiple :: [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 (String -> SDoc
text "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 :: ModSummary -> m ParsedModule
parseModule ms :: 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 -> [String] -> ApiAnns -> ParsedModule
ParsedModule ModSummary
ms (HsParsedModule -> ParsedSource
hpm_module HsParsedModule
hpm) (HsParsedModule -> [String]
hpm_src_files HsParsedModule
hpm)
                           (HsParsedModule -> ApiAnns
hpm_annotations HsParsedModule
hpm))
               -- See Note [Api annotations] in ApiAnnotation.hs

-- | Typecheck and rename a parsed module.
--
-- Throws a 'SourceError' if either fails.
typecheckModule :: GhcMonad m => ParsedModule -> m TypecheckedModule
typecheckModule :: ParsedModule -> m TypecheckedModule
typecheckModule pmod :: 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 }
 (tc_gbl_env :: TcGblEnv
tc_gbl_env, rn_info :: Maybe RenamedSource
rn_info)
       <- IO (TcGblEnv, Maybe RenamedSource)
-> m (TcGblEnv, Maybe RenamedSource)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (TcGblEnv, Maybe RenamedSource)
 -> m (TcGblEnv, Maybe RenamedSource))
-> IO (TcGblEnv, Maybe RenamedSource)
-> m (TcGblEnv, Maybe RenamedSource)
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 :: ParsedSource -> [String] -> ApiAnns -> HsParsedModule
HsParsedModule { hpm_module :: ParsedSource
hpm_module = ParsedModule -> ParsedSource
forall m. ParsedMod m => m -> ParsedSource
parsedSource ParsedModule
pmod,
                                       hpm_src_files :: [String]
hpm_src_files = ParsedModule -> [String]
pm_extra_src_files ParsedModule
pmod,
                                       hpm_annotations :: ApiAnns
hpm_annotations = ParsedModule -> ApiAnns
pm_annotations 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 :: ParsedModule
-> Maybe RenamedSource
-> TypecheckedSource
-> ModuleInfo
-> (TcGblEnv, ModDetails)
-> TypecheckedModule
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 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 :: TypeEnv
-> [AvailInfo]
-> Maybe GlobalRdrEnv
-> [ClsInst]
-> Maybe ModIface
-> SafeHaskellMode
-> ModBreaks
-> ModuleInfo
ModuleInfo {
           minf_type_env :: TypeEnv
minf_type_env  = ModDetails -> TypeEnv
md_types ModDetails
details,
           minf_exports :: [AvailInfo]
minf_exports   = ModDetails -> [AvailInfo]
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 :: TypecheckedModule -> m DesugaredModule
desugarModule tcm :: TypecheckedModule
tcm = do
 let ms :: ModSummary
ms = TypecheckedModule -> ModSummary
forall m. ParsedMod m => m -> ModSummary
modSummary TypecheckedModule
tcm
 let (tcg :: TcGblEnv
tcg, _) = 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 :: TypecheckedModule -> ModGuts -> DesugaredModule
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.hscTarget', 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 :: mod -> m mod
loadModule tcm :: 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 (tcg :: TcGblEnv
tcg, _details :: 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 t :: 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 -> String -> UTCTime -> IO Linkable
findObjectLinkable (ModSummary -> Module
ms_mod ModSummary
ms)
                                                  (ModLocation -> String
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)
                     _otherwise :: 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 1 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
$ \e :: 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})
    = String -> SDoc
text "%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 :: String -> m CoreModule
compileToCoreModule = Bool -> String -> m CoreModule
forall (m :: * -> *). GhcMonad m => Bool -> String -> 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 :: String -> m CoreModule
compileToCoreSimplified = Bool -> String -> m CoreModule
forall (m :: * -> *). GhcMonad m => Bool -> String -> m CoreModule
compileCore Bool
True

compileCore :: GhcMonad m => Bool -> FilePath -> m CoreModule
compileCore :: Bool -> String -> m CoreModule
compileCore simplify :: Bool
simplify fn :: String
fn = do
   -- First, set the target to the desired filename
   Target
target <- String -> Maybe Phase -> m Target
forall (m :: * -> *).
GhcMonad m =>
String -> Maybe Phase -> m Target
guessTarget String
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 ((String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
fn) (String -> Bool) -> (ModSummary -> String) -> ModSummary -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModSummary -> String
msHsFilePath) (ModuleGraph -> [ModSummary]
mgModSummaries ModuleGraph
modGraph) of
     Just modSummary :: ModSummary
modSummary -> do
       -- Now we have the module name;
       -- parse, typecheck and desugar the module
       (tcg :: TcGblEnv
tcg, mod_guts :: 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
               [String]
plugins <- IORef [String] -> IO [String]
forall a. IORef a -> IO a
readIORef (TcGblEnv -> IORef [String]
tcg_th_coreplugins TcGblEnv
tcg)
               HscEnv -> [String] -> ModGuts -> IO ModGuts
hscSimplify HscEnv
hsc_env [String]
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

     Nothing -> String -> m CoreModule
forall a. String -> 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 safe_mode :: SafeHaskellMode
safe_mode (Left (cg :: CgGuts
cg, md :: ModDetails
md)) = $WCoreModule :: Module -> TypeEnv -> CoreProgram -> SafeHaskellMode -> CoreModule
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 safe_mode :: SafeHaskellMode
safe_mode (Right mg :: ModGuts
mg) = $WCoreModule :: Module -> TypeEnv -> CoreProgram -> SafeHaskellMode -> CoreModule
CoreModule {
          cm_module :: Module
cm_module  = ModGuts -> Module
mg_module ModGuts
mg,
          cm_types :: TypeEnv
cm_types   = [Id] -> [TyCon] -> [FamInst] -> TypeEnv
typeEnvFromEntities (CoreProgram -> [Id]
forall b. [Bind b] -> [b]
bindersOfBinds (ModGuts -> CoreProgram
mg_binds ModGuts
mg))
                                           (ModGuts -> [TyCon]
mg_tcs 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 :: 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 :: ModuleName -> m Bool
isLoaded m :: 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
$ \hsc_env :: 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 :: 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
$ \hsc_env :: 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 :: 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
$ \hsc_env :: 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 :: 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
$ \hsc_env :: HscEnv
hsc_env ->
  PrintUnqualified -> m PrintUnqualified
forall (m :: * -> *) a. Monad m => a -> m a
return (DynFlags -> InteractiveContext -> PrintUnqualified
icPrintUnqual (HscEnv -> DynFlags
hsc_dflags 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 -> [AvailInfo]
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 :: Module -> m (Maybe ModuleInfo)
getModuleInfo mdl :: 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
$ \hsc_env :: 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 hsc_env :: HscEnv
hsc_env mdl :: 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 :: [AvailInfo]
avails = ModIface -> [AvailInfo]
mi_exports ModIface
iface
            pte :: TypeEnv
pte    = ExternalPackageState -> TypeEnv
eps_PTE ExternalPackageState
eps
            tys :: [TyThing]
tys    = [ TyThing
ty | Name
name <- (AvailInfo -> [Name]) -> [AvailInfo] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap AvailInfo -> [Name]
availNames [AvailInfo]
avails,
                            Just ty :: 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 :: TypeEnv
-> [AvailInfo]
-> Maybe GlobalRdrEnv
-> [ClsInst]
-> Maybe ModIface
-> SafeHaskellMode
-> ModBreaks
-> ModuleInfo
ModuleInfo {
                        minf_type_env :: TypeEnv
minf_type_env  = [TyThing] -> TypeEnv
mkTypeEnv [TyThing]
tys,
                        minf_exports :: [AvailInfo]
minf_exports   = [AvailInfo]
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 -> [AvailInfo] -> GlobalRdrEnv
availsToGlobalRdrEnv (Module -> ModuleName
moduleName Module
mdl) [AvailInfo]
avails,
                        minf_instances :: [ClsInst]
minf_instances = String -> [ClsInst]
forall a. HasCallStack => String -> a
error "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
mi_trust ModIface
iface,
                        minf_modBreaks :: ModBreaks
minf_modBreaks = ModBreaks
emptyModBreaks
                }))

getHomeModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
getHomeModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
getHomeModuleInfo hsc_env :: HscEnv
hsc_env mdl :: Module
mdl =
  case HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env) (Module -> ModuleName
moduleName Module
mdl) of
    Nothing  -> Maybe ModuleInfo -> IO (Maybe ModuleInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ModuleInfo
forall a. Maybe a
Nothing
    Just hmi :: 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 :: TypeEnv
-> [AvailInfo]
-> Maybe GlobalRdrEnv
-> [ClsInst]
-> Maybe ModIface
-> SafeHaskellMode
-> ModBreaks
-> ModuleInfo
ModuleInfo {
                        minf_type_env :: TypeEnv
minf_type_env  = ModDetails -> TypeEnv
md_types ModDetails
details,
                        minf_exports :: [AvailInfo]
minf_exports   = ModDetails -> [AvailInfo]
md_exports ModDetails
details,
                        minf_rdr_env :: Maybe GlobalRdrEnv
minf_rdr_env   = ModIface -> 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
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 minf :: ModuleInfo
minf = TypeEnv -> [TyThing]
typeEnvElts (ModuleInfo -> TypeEnv
minf_type_env ModuleInfo
minf)

modInfoTopLevelScope :: ModuleInfo -> Maybe [Name]
modInfoTopLevelScope :: ModuleInfo -> Maybe [Name]
modInfoTopLevelScope minf :: 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
gre_name ([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 minf :: ModuleInfo
minf = (AvailInfo -> [Name]) -> [AvailInfo] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap AvailInfo -> [Name]
availNames ([AvailInfo] -> [Name]) -> [AvailInfo] -> [Name]
forall a b. (a -> b) -> a -> b
$! ModuleInfo -> [AvailInfo]
minf_exports ModuleInfo
minf

modInfoExportsWithSelectors :: ModuleInfo -> [Name]
modInfoExportsWithSelectors :: ModuleInfo -> [Name]
modInfoExportsWithSelectors minf :: ModuleInfo
minf = (AvailInfo -> [Name]) -> [AvailInfo] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap AvailInfo -> [Name]
availNamesWithSelectors ([AvailInfo] -> [Name]) -> [AvailInfo] -> [Name]
forall a b. (a -> b) -> a -> b
$! ModuleInfo -> [AvailInfo]
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 minf :: ModuleInfo
minf name :: Name
name = Name -> NameSet -> Bool
elemNameSet Name
name ([AvailInfo] -> NameSet
availsToNameSet (ModuleInfo -> [AvailInfo]
minf_exports ModuleInfo
minf))

mkPrintUnqualifiedForModule :: GhcMonad m =>
                               ModuleInfo
                            -> m (Maybe PrintUnqualified) -- XXX: returns a Maybe X
mkPrintUnqualifiedForModule :: ModuleInfo -> m (Maybe PrintUnqualified)
mkPrintUnqualifiedForModule minf :: 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
$ \hsc_env :: HscEnv
hsc_env -> do
  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 (DynFlags -> GlobalRdrEnv -> PrintUnqualified
mkPrintUnqualified (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)) (ModuleInfo -> Maybe GlobalRdrEnv
minf_rdr_env ModuleInfo
minf))

modInfoLookupName :: GhcMonad m =>
                     ModuleInfo -> Name
                  -> m (Maybe TyThing) -- XXX: returns a Maybe X
modInfoLookupName :: ModuleInfo -> Name -> m (Maybe TyThing)
modInfoLookupName minf :: ModuleInfo
minf name :: 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
$ \hsc_env :: HscEnv
hsc_env -> do
   case TypeEnv -> Name -> Maybe TyThing
lookupTypeEnv (ModuleInfo -> TypeEnv
minf_type_env ModuleInfo
minf) Name
name of
     Just tyThing :: 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)
     Nothing      -> do
       ExternalPackageState
eps <- IO ExternalPackageState -> m ExternalPackageState
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ExternalPackageState -> m ExternalPackageState)
-> IO ExternalPackageState -> m ExternalPackageState
forall a b. (a -> b) -> a -> b
$ IORef ExternalPackageState -> IO ExternalPackageState
forall a. IORef a -> IO a
readIORef (HscEnv -> IORef ExternalPackageState
hsc_EPS HscEnv
hsc_env)
       Maybe TyThing -> m (Maybe TyThing)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe TyThing -> m (Maybe TyThing))
-> Maybe TyThing -> m (Maybe TyThing)
forall a b. (a -> b) -> a -> b
$! DynFlags -> HomePackageTable -> TypeEnv -> Name -> Maybe TyThing
lookupType (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)
                            (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env) (ExternalPackageState -> TypeEnv
eps_PTE ExternalPackageState
eps) 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 :: Id -> Bool
isDictonaryId id :: Id
id
  = case Type -> ([Id], ThetaType, Type)
tcSplitSigmaTy (Id -> Type
idType Id
id) of {
      (_tvs :: [Id]
_tvs, _theta :: ThetaType
_theta, tau :: 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 :: Name -> m (Maybe TyThing)
lookupGlobalName name :: 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
$ \hsc_env :: 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)
lookupTypeHscEnv HscEnv
hsc_env Name
name

findGlobalAnns :: (GhcMonad m, Typeable a) => ([Word8] -> a) -> AnnTarget Name -> m [a]
findGlobalAnns :: ([Word8] -> a) -> AnnTarget Name -> m [a]
findGlobalAnns deserialize :: [Word8] -> a
deserialize target :: 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
$ \hsc_env :: 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 :: 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
$ \hsc_env :: 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, Maybe (NameEnv ([ClsInst], [FamInst])))
getNameToInstancesIndex :: [Module]
-> Maybe [Module]
-> m (Messages, Maybe (NameEnv ([ClsInst], [FamInst])))
getNameToInstancesIndex visible_mods :: [Module]
visible_mods mods_to_load :: Maybe [Module]
mods_to_load = do
  HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
  IO (Messages, Maybe (NameEnv ([ClsInst], [FamInst])))
-> m (Messages, Maybe (NameEnv ([ClsInst], [FamInst])))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Messages, Maybe (NameEnv ([ClsInst], [FamInst])))
 -> m (Messages, Maybe (NameEnv ([ClsInst], [FamInst]))))
-> IO (Messages, Maybe (NameEnv ([ClsInst], [FamInst])))
-> m (Messages, Maybe (NameEnv ([ClsInst], [FamInst])))
forall a b. (a -> b) -> a -> b
$ HscEnv
-> TcRn (NameEnv ([ClsInst], [FamInst]))
-> IO (Messages, Maybe (NameEnv ([ClsInst], [FamInst])))
forall a. HscEnv -> TcRn a -> IO (Messages, Maybe a)
runTcInteractive HscEnv
hsc_env (TcRn (NameEnv ([ClsInst], [FamInst]))
 -> IO (Messages, Maybe (NameEnv ([ClsInst], [FamInst]))))
-> TcRn (NameEnv ([ClsInst], [FamInst]))
-> IO (Messages, Maybe (NameEnv ([ClsInst], [FamInst])))
forall a b. (a -> b) -> a -> b
$
    do { case Maybe [Module]
mods_to_load of
           Nothing -> HscEnv -> InteractiveContext -> TcM ()
loadUnqualIfaces HscEnv
hsc_env (HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env)
           Just mods :: [Module]
mods ->
             let doc :: SDoc
doc = String -> SDoc
text "Need interface for reporting instances in scope"
             in IfG () -> TcM ()
forall a. IfG a -> TcRn a
initIfaceTcRn (IfG () -> TcM ()) -> IfG () -> TcM ()
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
       ; (pkg_fie :: FamInstEnv
pkg_fie, home_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 TcRnDriver.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))
           | (nm :: Name
nm, (clss :: Seq ClsInst
clss, fams :: 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 compiler/main/Packages.hs
-- | 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 (pkgIdMap (pkgState dflags))
   return $
     [ mkModule pid modname
     | p <- pkgs
     , not only_exposed || exposed p
     , let pid = packageConfigId p
     , modname <- exposedModules p
               ++ map exportName (reexportedModules p) ]
               -}

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

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

-- | print a 'NamedThing', adding parentheses if the name is an operator.
pprParenSymName :: NamedThing a => a -> SDoc
pprParenSymName :: a -> SDoc
pprParenSymName a :: 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 IfaceSyn?  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 :: Module -> m (String, InputFileBuffer, DynFlags)
getModuleSourceAndFlags mod :: Module
mod = do
  ModSummary
m <- ModuleName -> m ModSummary
forall (m :: * -> *). GhcMonad m => ModuleName -> m ModSummary
getModSummary (Module -> ModuleName
moduleName Module
mod)
  case ModLocation -> Maybe String
ml_hs_file (ModLocation -> Maybe String) -> ModLocation -> Maybe String
forall a b. (a -> b) -> a -> b
$ ModSummary -> ModLocation
ms_location ModSummary
m of
    Nothing -> do DynFlags
dflags <- m DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
                  IO (String, InputFileBuffer, DynFlags)
-> m (String, InputFileBuffer, DynFlags)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (String, InputFileBuffer, DynFlags)
 -> m (String, InputFileBuffer, DynFlags))
-> IO (String, InputFileBuffer, DynFlags)
-> m (String, InputFileBuffer, DynFlags)
forall a b. (a -> b) -> a -> b
$ GhcApiError -> IO (String, InputFileBuffer, DynFlags)
forall e a. Exception e => e -> IO a
throwIO (GhcApiError -> IO (String, InputFileBuffer, DynFlags))
-> GhcApiError -> IO (String, InputFileBuffer, DynFlags)
forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> GhcApiError
mkApiErr DynFlags
dflags (String -> SDoc
text "No source available for module " SDoc -> SDoc -> SDoc
<+> Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
mod)
    Just sourceFile :: String
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
$ String -> IO InputFileBuffer
hGetStringBuffer String
sourceFile
        (String, InputFileBuffer, DynFlags)
-> m (String, InputFileBuffer, DynFlags)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
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 'HscTypes.SourceError' on parse error.
getTokenStream :: GhcMonad m => Module -> m [Located Token]
getTokenStream :: Module -> m [Located Token]
getTokenStream mod :: Module
mod = do
  (sourceFile :: String
sourceFile, source :: InputFileBuffer
source, flags :: DynFlags
flags) <- Module -> m (String, InputFileBuffer, DynFlags)
forall (m :: * -> *).
GhcMonad m =>
Module -> m (String, InputFileBuffer, DynFlags)
getModuleSourceAndFlags Module
mod
  let startLoc :: RealSrcLoc
startLoc = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc (String -> FastString
mkFastString String
sourceFile) 1 1
  case InputFileBuffer
-> RealSrcLoc -> DynFlags -> ParseResult [Located Token]
lexTokenStream InputFileBuffer
source RealSrcLoc
startLoc DynFlags
flags of
    POk _ ts :: [Located Token]
ts  -> [Located Token] -> m [Located Token]
forall (m :: * -> *) a. Monad m => a -> m a
return [Located Token]
ts
    PFailed _ span :: SrcSpan
span err :: SDoc
err ->
        do DynFlags
dflags <- m DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
           IO [Located Token] -> m [Located Token]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Located Token] -> m [Located Token])
-> IO [Located Token] -> m [Located Token]
forall a b. (a -> b) -> a -> b
$ SourceError -> IO [Located Token]
forall e a. Exception e => e -> IO a
throwIO (SourceError -> IO [Located Token])
-> SourceError -> IO [Located Token]
forall a b. (a -> b) -> a -> b
$ Bag WarnMsg -> SourceError
mkSrcErr (WarnMsg -> Bag WarnMsg
forall a. a -> Bag a
unitBag (WarnMsg -> Bag WarnMsg) -> WarnMsg -> Bag WarnMsg
forall a b. (a -> b) -> a -> b
$ DynFlags -> SrcSpan -> SDoc -> WarnMsg
mkPlainErrMsg DynFlags
dflags SrcSpan
span SDoc
err)

-- | 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 :: Module -> m [(Located Token, String)]
getRichTokenStream mod :: Module
mod = do
  (sourceFile :: String
sourceFile, source :: InputFileBuffer
source, flags :: DynFlags
flags) <- Module -> m (String, InputFileBuffer, DynFlags)
forall (m :: * -> *).
GhcMonad m =>
Module -> m (String, InputFileBuffer, DynFlags)
getModuleSourceAndFlags Module
mod
  let startLoc :: RealSrcLoc
startLoc = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc (String -> FastString
mkFastString String
sourceFile) 1 1
  case InputFileBuffer
-> RealSrcLoc -> DynFlags -> ParseResult [Located Token]
lexTokenStream InputFileBuffer
source RealSrcLoc
startLoc DynFlags
flags of
    POk _ ts :: [Located Token]
ts -> [(Located Token, String)] -> m [(Located Token, String)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Located Token, String)] -> m [(Located Token, String)])
-> [(Located Token, String)] -> m [(Located Token, String)]
forall a b. (a -> b) -> a -> b
$ RealSrcLoc
-> InputFileBuffer -> [Located Token] -> [(Located Token, String)]
addSourceToTokens RealSrcLoc
startLoc InputFileBuffer
source [Located Token]
ts
    PFailed _ span :: SrcSpan
span err :: SDoc
err ->
        do DynFlags
dflags <- m DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
           IO [(Located Token, String)] -> m [(Located Token, String)]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [(Located Token, String)] -> m [(Located Token, String)])
-> IO [(Located Token, String)] -> m [(Located Token, String)]
forall a b. (a -> b) -> a -> b
$ SourceError -> IO [(Located Token, String)]
forall e a. Exception e => e -> IO a
throwIO (SourceError -> IO [(Located Token, String)])
-> SourceError -> IO [(Located Token, String)]
forall a b. (a -> b) -> a -> b
$ Bag WarnMsg -> SourceError
mkSrcErr (WarnMsg -> Bag WarnMsg
forall a. a -> Bag a
unitBag (WarnMsg -> Bag WarnMsg) -> WarnMsg -> Bag WarnMsg
forall a b. (a -> b) -> a -> b
$ DynFlags -> SrcSpan -> SDoc -> WarnMsg
mkPlainErrMsg DynFlags
dflags SrcSpan
span SDoc
err)

-- | 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, String)]
addSourceToTokens _ _ [] = []
addSourceToTokens loc :: RealSrcLoc
loc buf :: InputFileBuffer
buf (t :: Located Token
t@(Located Token -> Located (SrcSpanLess (Located Token))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L span :: SrcSpan
span _) : ts :: [Located Token]
ts)
    = case SrcSpan
span of
      UnhelpfulSpan _ -> (Located Token
t,"") (Located Token, String)
-> [(Located Token, String)] -> [(Located Token, String)]
forall a. a -> [a] -> [a]
: RealSrcLoc
-> InputFileBuffer -> [Located Token] -> [(Located Token, String)]
addSourceToTokens RealSrcLoc
loc InputFileBuffer
buf [Located Token]
ts
      RealSrcSpan s :: RealSrcSpan
s   -> (Located Token
t,String
str) (Located Token, String)
-> [(Located Token, String)] -> [(Located Token, String)]
forall a. a -> [a] -> [a]
: RealSrcLoc
-> InputFileBuffer -> [Located Token] -> [(Located Token, String)]
addSourceToTokens RealSrcLoc
newLoc InputFileBuffer
newBuf [Located Token]
ts
        where
          (newLoc :: RealSrcLoc
newLoc, newBuf :: InputFileBuffer
newBuf, str :: String
str) = String
-> RealSrcLoc
-> InputFileBuffer
-> (RealSrcLoc, InputFileBuffer, String)
go "" RealSrcLoc
loc InputFileBuffer
buf
          start :: RealSrcLoc
start = RealSrcSpan -> RealSrcLoc
realSrcSpanStart RealSrcSpan
s
          end :: RealSrcLoc
end = RealSrcSpan -> RealSrcLoc
realSrcSpanEnd RealSrcSpan
s
          go :: String
-> RealSrcLoc
-> InputFileBuffer
-> (RealSrcLoc, InputFileBuffer, String)
go acc :: String
acc loc :: RealSrcLoc
loc buf :: InputFileBuffer
buf | RealSrcLoc
loc RealSrcLoc -> RealSrcLoc -> Bool
forall a. Ord a => a -> a -> Bool
< RealSrcLoc
start = String
-> RealSrcLoc
-> InputFileBuffer
-> (RealSrcLoc, InputFileBuffer, String)
go String
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 = String
-> RealSrcLoc
-> InputFileBuffer
-> (RealSrcLoc, InputFileBuffer, String)
go (Char
chChar -> String -> String
forall a. a -> [a] -> [a]
:String
acc) RealSrcLoc
nLoc InputFileBuffer
nBuf
                         | Bool
otherwise = (RealSrcLoc
loc, InputFileBuffer
buf, String -> String
forall a. [a] -> [a]
reverse String
acc)
              where (ch :: Char
ch, nBuf :: 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, String)] -> String
showRichTokenStream ts :: [(Located Token, String)]
ts = RealSrcLoc -> [(Located Token, String)] -> String -> String
forall a.
HasSrcSpan a =>
RealSrcLoc -> [(a, String)] -> String -> String
go RealSrcLoc
startLoc [(Located Token, String)]
ts ""
    where sourceFile :: FastString
sourceFile = [SrcSpan] -> FastString
getFile ([SrcSpan] -> FastString) -> [SrcSpan] -> FastString
forall a b. (a -> b) -> a -> b
$ ((Located Token, String) -> SrcSpan)
-> [(Located Token, String)] -> [SrcSpan]
forall a b. (a -> b) -> [a] -> [b]
map (Located Token -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc (Located Token -> SrcSpan)
-> ((Located Token, String) -> Located Token)
-> (Located Token, String)
-> SrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Located Token, String) -> Located Token
forall a b. (a, b) -> a
fst) [(Located Token, String)]
ts
          getFile :: [SrcSpan] -> FastString
getFile [] = String -> FastString
forall a. String -> a
panic "showRichTokenStream: No source file found"
          getFile (UnhelpfulSpan _ : xs :: [SrcSpan]
xs) = [SrcSpan] -> FastString
getFile [SrcSpan]
xs
          getFile (RealSrcSpan s :: RealSrcSpan
s : _) = RealSrcSpan -> FastString
srcSpanFile RealSrcSpan
s
          startLoc :: RealSrcLoc
startLoc = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc FastString
sourceFile 1 1
          go :: RealSrcLoc -> [(a, String)] -> String -> String
go _ [] = String -> String
forall a. a -> a
id
          go loc :: RealSrcLoc
loc ((a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L span :: SrcSpan
span _, str :: String
str):ts :: [(a, String)]
ts)
              = case SrcSpan
span of
                UnhelpfulSpan _ -> RealSrcLoc -> [(a, String)] -> String -> String
go RealSrcLoc
loc [(a, String)]
ts
                RealSrcSpan s :: RealSrcSpan
s
                 | Int
locLine Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
tokLine -> ((Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
tokCol Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
locCol) ' ') String -> String -> String
forall a. [a] -> [a] -> [a]
++)
                                       (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
str String -> String -> String
forall a. [a] -> [a] -> [a]
++)
                                       (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealSrcLoc -> [(a, String)] -> String -> String
go RealSrcLoc
tokEnd [(a, String)]
ts
                 | Bool
otherwise -> ((Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
tokLine Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
locLine) '\n') String -> String -> String
forall a. [a] -> [a] -> [a]
++)
                               (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
tokCol Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) ' ') String -> String -> String
forall a. [a] -> [a] -> [a]
++)
                              (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
str String -> String -> String
forall a. [a] -> [a] -> [a]
++)
                              (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealSrcLoc -> [(a, String)] -> String -> String
go RealSrcLoc
tokEnd [(a, String)]
ts
                  where (locLine :: Int
locLine, locCol :: Int
locCol) = (RealSrcLoc -> Int
srcLocLine RealSrcLoc
loc, RealSrcLoc -> Int
srcLocCol RealSrcLoc
loc)
                        (tokLine :: Int
tokLine, tokCol :: 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 :: ModuleName -> Maybe FastString -> m Module
findModule mod_name :: ModuleName
mod_name maybe_pkg :: 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
$ \hsc_env :: HscEnv
hsc_env -> do
  let
    dflags :: DynFlags
dflags   = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
    this_pkg :: UnitId
this_pkg = DynFlags -> UnitId
thisPackage DynFlags
dflags
  --
  case Maybe FastString
maybe_pkg of
    Just pkg :: FastString
pkg | FastString -> UnitId
fsToUnitId FastString
pkg UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
/= UnitId
this_pkg Bool -> Bool -> Bool
&& FastString
pkg FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
/= String -> FastString
fsLit "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 _ m :: Module
m -> Module -> IO Module
forall (m :: * -> *) a. Monad m => a -> m a
return Module
m
        err :: FindResult
err       -> WarnMsg -> IO Module
forall (m :: * -> *) ab. MonadIO m => WarnMsg -> m ab
throwOneError (WarnMsg -> IO Module) -> WarnMsg -> IO Module
forall a b. (a -> b) -> a -> b
$ DynFlags -> SrcSpan -> ModuleName -> FindResult -> WarnMsg
noModError DynFlags
dflags SrcSpan
noSrcSpan ModuleName
mod_name FindResult
err
    _otherwise :: 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 m :: Module
m  -> Module -> m Module
forall (m :: * -> *) a. Monad m => a -> m a
return Module
m
        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 loc :: ModLocation
loc m :: Module
m | Module -> UnitId
moduleUnitId Module
m UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
/= UnitId
this_pkg -> 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
             err :: FindResult
err -> WarnMsg -> IO Module
forall (m :: * -> *) ab. MonadIO m => WarnMsg -> m ab
throwOneError (WarnMsg -> IO Module) -> WarnMsg -> IO Module
forall a b. (a -> b) -> a -> b
$ DynFlags -> SrcSpan -> ModuleName -> FindResult -> WarnMsg
noModError DynFlags
dflags SrcSpan
noSrcSpan ModuleName
mod_name FindResult
err

modNotLoadedError :: DynFlags -> Module -> ModLocation -> IO a
modNotLoadedError :: DynFlags -> Module -> ModLocation -> IO a
modNotLoadedError dflags :: DynFlags
dflags m :: Module
m loc :: ModLocation
loc = GhcException -> IO a
forall a. GhcException -> IO a
throwGhcExceptionIO (GhcException -> IO a) -> GhcException -> IO a
forall a b. (a -> b) -> a -> b
$ String -> GhcException
CmdLineError (String -> GhcException) -> String -> GhcException
forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (SDoc -> String) -> SDoc -> String
forall a b. (a -> b) -> a -> b
$
   String -> SDoc
text "module is not loaded:" SDoc -> SDoc -> SDoc
<+>
   SDoc -> SDoc
quotes (ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Module -> ModuleName
moduleName Module
m)) SDoc -> SDoc -> SDoc
<+>
   SDoc -> SDoc
parens (String -> SDoc
text (String -> Maybe String -> String
forall a. HasCallStack => String -> Maybe a -> a
expectJust "modNotLoadedError" (ModLocation -> Maybe String
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 :: ModuleName -> Maybe FastString -> m Module
lookupModule mod_name :: ModuleName
mod_name (Just pkg :: 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 mod_name :: ModuleName
mod_name 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
$ \hsc_env :: 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 m :: Module
m  -> Module -> m Module
forall (m :: * -> *) a. Monad m => a -> m a
return Module
m
    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 _ m :: Module
m -> Module -> IO Module
forall (m :: * -> *) a. Monad m => a -> m a
return Module
m
        err :: FindResult
err       -> WarnMsg -> IO Module
forall (m :: * -> *) ab. MonadIO m => WarnMsg -> m ab
throwOneError (WarnMsg -> IO Module) -> WarnMsg -> IO Module
forall a b. (a -> b) -> a -> b
$ DynFlags -> SrcSpan -> ModuleName -> FindResult -> WarnMsg
noModError (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) SrcSpan
noSrcSpan ModuleName
mod_name FindResult
err

lookupLoadedHomeModule :: GhcMonad m => ModuleName -> m (Maybe Module)
lookupLoadedHomeModule :: ModuleName -> m (Maybe Module)
lookupLoadedHomeModule mod_name :: 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
$ \hsc_env :: HscEnv
hsc_env ->
  case HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env) ModuleName
mod_name of
    Just mod_info :: 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
mi_module (HomeModInfo -> ModIface
hm_iface HomeModInfo
mod_info)))
    _not_a_home_module :: 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 :: Module -> m Bool
isModuleTrusted m :: 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
$ \hsc_env :: 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 InstalledUnitId)
moduleTrustReqs :: Module -> m (Bool, Set InstalledUnitId)
moduleTrustReqs m :: Module
m = (HscEnv -> m (Bool, Set InstalledUnitId))
-> m (Bool, Set InstalledUnitId)
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession ((HscEnv -> m (Bool, Set InstalledUnitId))
 -> m (Bool, Set InstalledUnitId))
-> (HscEnv -> m (Bool, Set InstalledUnitId))
-> m (Bool, Set InstalledUnitId)
forall a b. (a -> b) -> a -> b
$ \hsc_env :: HscEnv
hsc_env ->
    IO (Bool, Set InstalledUnitId) -> m (Bool, Set InstalledUnitId)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Bool, Set InstalledUnitId) -> m (Bool, Set InstalledUnitId))
-> IO (Bool, Set InstalledUnitId) -> m (Bool, Set InstalledUnitId)
forall a b. (a -> b) -> a -> b
$ HscEnv -> Module -> SrcSpan -> IO (Bool, Set InstalledUnitId)
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 :: String -> m ()
setGHCiMonad name :: String
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
$ \hsc_env :: 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 -> String -> IO Name
hscIsGHCiMonad HscEnv
hsc_env String
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
$ \s :: 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 :: 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 :: History -> m SrcSpan
getHistorySpan h :: 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
$ \hsc_env :: 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
InteractiveEval.getHistorySpan HscEnv
hsc_env History
h

obtainTermFromVal :: GhcMonad m => Int ->  Bool -> Type -> a -> m Term
obtainTermFromVal :: Int -> Bool -> Type -> a -> m Term
obtainTermFromVal bound :: Int
bound force :: Bool
force ty :: Type
ty a :: 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
$ \hsc_env :: 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
InteractiveEval.obtainTermFromVal HscEnv
hsc_env Int
bound Bool
force Type
ty a
a

obtainTermFromId :: GhcMonad m => Int -> Bool -> Id -> m Term
obtainTermFromId :: Int -> Bool -> Id -> m Term
obtainTermFromId bound :: Int
bound force :: Bool
force id :: Id
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
$ \hsc_env :: 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 -> Id -> IO Term
InteractiveEval.obtainTermFromId HscEnv
hsc_env Int
bound Bool
force Id
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 :: Name -> m (Maybe TyThing)
lookupName name :: 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
$ \hsc_env :: 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 GhcPs)))

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

     PFailed warnFn :: DynFlags -> Messages
warnFn span :: SrcSpan
span err :: SDoc
err   ->
         let (warns :: Bag WarnMsg
warns,_) = DynFlags -> Messages
warnFn DynFlags
dflags in
         (Bag WarnMsg
warns, Bag WarnMsg -> Either (Bag WarnMsg) ParsedSource
forall a b. a -> Either a b
Left (Bag WarnMsg -> Either (Bag WarnMsg) ParsedSource)
-> Bag WarnMsg -> Either (Bag WarnMsg) ParsedSource
forall a b. (a -> b) -> a -> b
$ WarnMsg -> Bag WarnMsg
forall a. a -> Bag a
unitBag (DynFlags -> SrcSpan -> SDoc -> WarnMsg
mkPlainErrMsg DynFlags
dflags SrcSpan
span SDoc
err))

     POk pst :: PState
pst rdr_module :: ParsedSource
rdr_module ->
         let (warns :: Bag WarnMsg
warns,_) = PState -> DynFlags -> Messages
getMessages PState
pst DynFlags
dflags in
         (Bag WarnMsg
warns, ParsedSource -> Either (Bag WarnMsg) ParsedSource
forall a b. b -> Either a b
Right ParsedSource
rdr_module)