module GHC (
defaultErrorHandler,
defaultCleanupHandler,
prettyPrintGhcErrors,
Ghc, GhcT, GhcMonad(..), HscEnv,
runGhc, runGhcT, initGhcMonad,
gcatch, gbracket, gfinally,
printException,
handleSourceError,
needsTemplateHaskell,
DynFlags(..), GeneralFlag(..), Severity(..), HscTarget(..), gopt,
GhcMode(..), GhcLink(..), defaultObjectTarget,
parseDynamicFlags,
getSessionDynFlags, setSessionDynFlags,
getProgramDynFlags, setProgramDynFlags,
getInteractiveDynFlags, setInteractiveDynFlags,
parseStaticFlags,
Target(..), TargetId(..), Phase,
setTargets,
getTargets,
addTarget,
removeTarget,
guessTarget,
depanal,
load, LoadHowMuch(..), InteractiveImport(..),
SuccessFlag(..), succeeded, failed,
defaultWarnErrLogger, WarnErrLogger,
workingDirectoryChanged,
parseModule, typecheckModule, desugarModule, loadModule,
ParsedModule(..), TypecheckedModule(..), DesugaredModule(..),
TypecheckedSource, ParsedSource, RenamedSource,
TypecheckedMod, ParsedMod,
moduleInfo, renamedSource, typecheckedSource,
parsedSource, coreModule,
CoreModule(..),
compileToCoreModule, compileToCoreSimplified,
compileCoreToObj,
ModuleGraph, ModSummary(..), ms_mod_name, ModLocation(..),
getModSummary,
getModuleGraph,
isLoaded,
topSortModuleGraph,
ModuleInfo,
getModuleInfo,
modInfoTyThings,
modInfoTopLevelScope,
modInfoExports,
modInfoInstances,
modInfoIsExportedName,
modInfoLookupName,
modInfoIface,
modInfoSafe,
lookupGlobalName,
findGlobalAnns,
mkPrintUnqualifiedForModule,
ModIface(..),
SafeHaskellMode(..),
packageDbModules,
PrintUnqualified, alwaysQualify,
getBindings, getInsts, getPrintUnqual,
findModule, lookupModule,
#ifdef GHCI
isModuleTrusted,
moduleTrustReqs,
setContext, getContext,
getNamesInScope,
getRdrNamesInScope,
getGRE,
moduleIsInterpreted,
getInfo,
exprType,
typeKind,
parseName,
RunResult(..),
runStmt, runStmtWithLocation, runDecls, runDeclsWithLocation,
parseImportDecl, SingleStep(..),
resume,
Resume(resumeStmt, resumeThreadId, resumeBreakInfo, resumeSpan,
resumeHistory, resumeHistoryIx),
History(historyBreakInfo, historyEnclosingDecls),
GHC.getHistorySpan, getHistoryModule,
getResumeContext,
abandon, abandonAll,
InteractiveEval.back,
InteractiveEval.forward,
showModule,
isModuleInterpreted,
InteractiveEval.compileExpr, HValue, dynCompileExpr,
GHC.obtainTermFromId, GHC.obtainTermFromVal, reconstructType,
modInfoModBreaks,
ModBreaks(..), BreakIndex,
BreakInfo(breakInfo_number, breakInfo_module),
BreakArray, setBreakOn, setBreakOff, getBreak,
#endif
lookupName,
#ifdef GHCI
setGHCiMonad,
#endif
PackageId,
Module, mkModule, pprModule, moduleName, modulePackageId,
ModuleName, mkModuleName, moduleNameString,
Name,
isExternalName, nameModule, pprParenSymName, nameSrcSpan,
NamedThing(..),
RdrName(Qual,Unqual),
Id, idType,
isImplicitId, isDeadBinder,
isExportedId, isLocalId, isGlobalId,
isRecordSelector,
isPrimOpId, isFCallId, isClassOpId_maybe,
isDataConWorkId, idDataCon,
isBottomingId, isDictonaryId,
recordSelectorFieldLabel,
TyCon,
tyConTyVars, tyConDataCons, tyConArity,
isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon,
isFamilyTyCon, isOpenFamilyTyCon, tyConClass_maybe,
synTyConRhs_maybe, synTyConDefn_maybe, synTyConResKind,
TyVar,
alphaTyVars,
DataCon,
dataConSig, dataConType, dataConTyCon, dataConFieldLabels,
dataConIsInfix, isVanillaDataCon, dataConUserType,
dataConStrictMarks,
StrictnessMark(..), isMarkedStrict,
Class,
classMethods, classSCTheta, classTvsFds, classATs,
pprFundeps,
ClsInst,
instanceDFunId,
pprInstance, pprInstanceHdr,
pprFamInst,
FamInst,
Type, splitForAllTys, funResultTy,
pprParendType, pprTypeApp,
Kind,
PredType,
ThetaType, pprForAll, pprThetaArrowTy,
TyThing(..),
module HsSyn,
FixityDirection(..),
defaultFixity, maxPrecedence,
negateFixity,
compareFixity,
SrcLoc(..), RealSrcLoc,
mkSrcLoc, noSrcLoc,
srcLocFile, srcLocLine, srcLocCol,
SrcSpan(..), RealSrcSpan,
mkSrcSpan, srcLocSpan, isGoodSrcSpan, noSrcSpan,
srcSpanStart, srcSpanEnd,
srcSpanFile,
srcSpanStartLine, srcSpanEndLine,
srcSpanStartCol, srcSpanEndCol,
GenLocated(..), Located,
noLoc, mkGeneralLocated,
getLoc, unLoc,
eqLocated, cmpLocated, combineLocs, addCLoc,
leftmost_smallest, leftmost_largest, rightmost,
spans, isSubspanOf,
GhcException(..), showGhcException,
Token,
getTokenStream, getRichTokenStream,
showRichTokenStream, addSourceToTokens,
parser,
--sessionHscEnv,
cyclicModuleErr,
) where
#include "HsVersions.h"
#ifdef GHCI
import ByteCodeInstr
import BreakArray
import InteractiveEval
#endif
import HscMain
import GhcMake
import DriverPipeline ( compileOne' )
import GhcMonad
import TcRnMonad ( finalSafeMode )
import TcRnTypes
import Packages
import NameSet
import RdrName
import qualified HsSyn
import HsSyn
import Type hiding( typeKind )
import Kind ( synTyConResKind )
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
import SrcLoc
import CoreSyn
import TidyPgm
import DriverPhases ( Phase(..), isHaskellSrcFilename )
import Finder
import HscTypes
import DynFlags
import StaticFlags
import SysTools
import Annotations
import Module
import UniqFM
import Panic
import Platform
import Bag ( unitBag )
import ErrUtils
import MonadUtils
import Util
import StringBuffer
import Outputable
import BasicTypes
import Maybes ( expectJust )
import FastString
import qualified Parser
import Lexer
import System.Directory ( doesFileExist, getCurrentDirectory )
import Data.Maybe
import Data.List ( find )
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
import System.IO
import Prelude hiding (init)
defaultErrorHandler :: (ExceptionMonad m, MonadIO m)
=> FatalMessager -> FlushOut -> m a -> m a
defaultErrorHandler fm (FlushOut flushOut) inner =
ghandle (\exception -> liftIO $ do
flushOut
case fromException exception of
Just (ioe :: IOException) ->
fatalErrorMsg'' fm (show ioe)
_ -> case fromException exception of
Just UserInterrupt ->
liftIO $ throwIO UserInterrupt
Just StackOverflow ->
fatalErrorMsg'' fm "stack overflow: use +RTS -K<size> to increase it"
_ -> case fromException exception of
Just (ex :: ExitCode) -> liftIO $ throwIO ex
_ ->
fatalErrorMsg'' fm
(show (Panic (show exception)))
exitWith (ExitFailure 1)
) $
handleGhcException
(\ge -> liftIO $ do
flushOut
case ge of
PhaseFailed _ code -> exitWith code
Signal _ -> exitWith (ExitFailure 1)
_ -> do fatalErrorMsg'' fm (show ge)
exitWith (ExitFailure 1)
) $
inner
defaultCleanupHandler :: (ExceptionMonad m, MonadIO m) =>
DynFlags -> m a -> m a
defaultCleanupHandler dflags inner =
inner `gfinally`
(liftIO $ do
cleanTempFiles dflags
cleanTempDirs dflags
)
runGhc :: Maybe FilePath
-> Ghc a
-> IO a
runGhc mb_top_dir ghc = do
ref <- newIORef (panic "empty session")
let session = Session ref
flip unGhc session $ do
initGhcMonad mb_top_dir
ghc
runGhcT :: (ExceptionMonad m, Functor m, MonadIO m) =>
Maybe FilePath
-> GhcT m a
-> m a
runGhcT mb_top_dir ghct = do
ref <- liftIO $ newIORef (panic "empty session")
let session = Session ref
flip unGhcT session $ do
initGhcMonad mb_top_dir
ghct
initGhcMonad :: GhcMonad m => Maybe FilePath -> m ()
initGhcMonad mb_top_dir
= do { env <- liftIO $
do { installSignalHandlers
; initStaticOpts
; mySettings <- initSysTools mb_top_dir
; dflags <- initDynFlags (defaultDynFlags mySettings)
; checkBrokenTablesNextToCode dflags
; setUnsafeGlobalDynFlags dflags
; newHscEnv dflags }
; setSession env }
checkBrokenTablesNextToCode :: MonadIO m => DynFlags -> m ()
checkBrokenTablesNextToCode dflags
= do { broken <- checkBrokenTablesNextToCode' dflags
; when broken
$ do { _ <- liftIO $ throwIO $ mkApiErr dflags invalidLdErr
; fail "unsupported linker"
}
}
where
invalidLdErr = text "Tables-next-to-code not supported on ARM" <+>
text "when using binutils ld (please see:" <+>
text "https://sourceware.org/bugzilla/show_bug.cgi?id=16177)"
checkBrokenTablesNextToCode' :: MonadIO m => DynFlags -> m Bool
checkBrokenTablesNextToCode' dflags
| not (isARM arch) = return False
| WayDyn `notElem` ways dflags = return False
| not (tablesNextToCode dflags) = return False
| otherwise = do
linkerInfo <- liftIO $ getLinkerInfo dflags
case linkerInfo of
GnuLD _ -> return True
_ -> return False
where platform = targetPlatform dflags
arch = platformArch platform
setSessionDynFlags :: GhcMonad m => DynFlags -> m [PackageId]
setSessionDynFlags dflags = do
(dflags', preload) <- liftIO $ initPackages dflags
modifySession $ \h -> h{ hsc_dflags = dflags'
, hsc_IC = (hsc_IC h){ ic_dflags = dflags' } }
invalidateModSummaryCache
return preload
setProgramDynFlags :: GhcMonad m => DynFlags -> m [PackageId]
setProgramDynFlags dflags = do
(dflags', preload) <- liftIO $ initPackages dflags
modifySession $ \h -> h{ hsc_dflags = dflags' }
invalidateModSummaryCache
return preload
invalidateModSummaryCache :: GhcMonad m => m ()
invalidateModSummaryCache =
modifySession $ \h -> h { hsc_mod_graph = map inval (hsc_mod_graph h) }
where
inval ms = ms { ms_hs_date = addUTCTime (1) (ms_hs_date ms) }
getProgramDynFlags :: GhcMonad m => m DynFlags
getProgramDynFlags = getSessionDynFlags
setInteractiveDynFlags :: GhcMonad m => DynFlags -> m ()
setInteractiveDynFlags dflags = do
modifySession $ \h -> h{ hsc_IC = (hsc_IC h) { ic_dflags = dflags }}
getInteractiveDynFlags :: GhcMonad m => m DynFlags
getInteractiveDynFlags = withSession $ \h -> return (ic_dflags (hsc_IC h))
parseDynamicFlags :: MonadIO m =>
DynFlags -> [Located String]
-> m (DynFlags, [Located String], [Located String])
parseDynamicFlags = parseDynamicFlagsCmdLine
setTargets :: GhcMonad m => [Target] -> m ()
setTargets targets = modifySession (\h -> h{ hsc_targets = targets })
getTargets :: GhcMonad m => m [Target]
getTargets = withSession (return . hsc_targets)
addTarget :: GhcMonad m => Target -> m ()
addTarget target
= modifySession (\h -> h{ hsc_targets = target : hsc_targets h })
removeTarget :: GhcMonad m => TargetId -> m ()
removeTarget target_id
= modifySession (\h -> h{ hsc_targets = filter (hsc_targets h) })
where
filter targets = [ t | t@(Target id _ _) <- targets, id /= target_id ]
guessTarget :: GhcMonad m => String -> Maybe Phase -> m Target
guessTarget str (Just phase)
= return (Target (TargetFile str (Just phase)) True Nothing)
guessTarget str Nothing
| isHaskellSrcFilename file
= return (target (TargetFile file Nothing))
| otherwise
= do exists <- liftIO $ doesFileExist hs_file
if exists
then return (target (TargetFile hs_file Nothing))
else do
exists <- liftIO $ doesFileExist lhs_file
if exists
then return (target (TargetFile lhs_file Nothing))
else do
if looksLikeModuleName file
then return (target (TargetModule (mkModuleName file)))
else do
dflags <- getDynFlags
liftIO $ throwGhcExceptionIO
(ProgramError (showSDoc dflags $
text "target" <+> quotes (text file) <+>
text "is not a module name or a source file"))
where
(file,obj_allowed)
| '*':rest <- str = (rest, False)
| otherwise = (str, True)
hs_file = file <.> "hs"
lhs_file = file <.> "lhs"
target tid = Target tid obj_allowed Nothing
workingDirectoryChanged :: GhcMonad m => m ()
workingDirectoryChanged = withSession $ (liftIO . flushFinderCaches)
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)
class TypecheckedMod m => DesugaredMod m where
coreModule :: m -> ModGuts
data ParsedModule =
ParsedModule { pm_mod_summary :: ModSummary
, pm_parsed_source :: ParsedSource
, pm_extra_src_files :: [FilePath] }
instance ParsedMod ParsedModule where
modSummary m = pm_mod_summary m
parsedSource m = pm_parsed_source m
data TypecheckedModule =
TypecheckedModule { tm_parsed_module :: ParsedModule
, tm_renamed_source :: Maybe RenamedSource
, tm_typechecked_source :: TypecheckedSource
, tm_checked_module_info :: ModuleInfo
, tm_internals_ :: (TcGblEnv, ModDetails)
}
instance ParsedMod TypecheckedModule where
modSummary m = modSummary (tm_parsed_module m)
parsedSource m = parsedSource (tm_parsed_module m)
instance TypecheckedMod TypecheckedModule where
renamedSource m = tm_renamed_source m
typecheckedSource m = tm_typechecked_source m
moduleInfo m = tm_checked_module_info m
tm_internals m = tm_internals_ m
data DesugaredModule =
DesugaredModule { dm_typechecked_module :: TypecheckedModule
, dm_core_module :: ModGuts
}
instance ParsedMod DesugaredModule where
modSummary m = modSummary (dm_typechecked_module m)
parsedSource m = parsedSource (dm_typechecked_module m)
instance TypecheckedMod DesugaredModule where
renamedSource m = renamedSource (dm_typechecked_module m)
typecheckedSource m = typecheckedSource (dm_typechecked_module m)
moduleInfo m = moduleInfo (dm_typechecked_module m)
tm_internals m = tm_internals_ (dm_typechecked_module m)
instance DesugaredMod DesugaredModule where
coreModule m = dm_core_module m
type ParsedSource = Located (HsModule RdrName)
type RenamedSource = (HsGroup Name, [LImportDecl Name], Maybe [LIE Name],
Maybe LHsDocString)
type TypecheckedSource = LHsBinds Id
getModSummary :: GhcMonad m => ModuleName -> m ModSummary
getModSummary mod = do
mg <- liftM hsc_mod_graph getSession
case [ ms | ms <- mg, ms_mod_name ms == mod, not (isBootSummary ms) ] of
[] -> do dflags <- getDynFlags
liftIO $ throwIO $ mkApiErr dflags (text "Module not part of module graph")
[ms] -> return ms
multiple -> do dflags <- getDynFlags
liftIO $ throwIO $ mkApiErr dflags (text "getModSummary is ambiguous: " <+> ppr multiple)
parseModule :: GhcMonad m => ModSummary -> m ParsedModule
parseModule ms = do
hsc_env <- getSession
let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }
hpm <- liftIO $ hscParse hsc_env_tmp ms
return (ParsedModule ms (hpm_module hpm) (hpm_src_files hpm))
typecheckModule :: GhcMonad m => ParsedModule -> m TypecheckedModule
typecheckModule pmod = do
let ms = modSummary pmod
hsc_env <- getSession
let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }
(tc_gbl_env, rn_info)
<- liftIO $ hscTypecheckRename hsc_env_tmp ms $
HsParsedModule { hpm_module = parsedSource pmod,
hpm_src_files = pm_extra_src_files pmod }
details <- liftIO $ makeSimpleDetails hsc_env_tmp tc_gbl_env
safe <- liftIO $ finalSafeMode (ms_hspp_opts ms) tc_gbl_env
return $
TypecheckedModule {
tm_internals_ = (tc_gbl_env, details),
tm_parsed_module = pmod,
tm_renamed_source = rn_info,
tm_typechecked_source = tcg_binds tc_gbl_env,
tm_checked_module_info =
ModuleInfo {
minf_type_env = md_types details,
minf_exports = availsToNameSet $ md_exports details,
minf_rdr_env = Just (tcg_rdr_env tc_gbl_env),
minf_instances = md_insts details,
minf_iface = Nothing,
minf_safe = safe
#ifdef GHCI
,minf_modBreaks = emptyModBreaks
#endif
}}
desugarModule :: GhcMonad m => TypecheckedModule -> m DesugaredModule
desugarModule tcm = do
let ms = modSummary tcm
let (tcg, _) = tm_internals tcm
hsc_env <- getSession
let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }
guts <- liftIO $ hscDesugar hsc_env_tmp ms tcg
return $
DesugaredModule {
dm_typechecked_module = tcm,
dm_core_module = guts
}
loadModule :: (TypecheckedMod mod, GhcMonad m) => mod -> m mod
loadModule tcm = do
let ms = modSummary tcm
let mod = ms_mod_name ms
let loc = ms_location ms
let (tcg, _details) = tm_internals tcm
mb_linkable <- case ms_obj_date ms of
Just t | t > ms_hs_date ms -> do
l <- liftIO $ findObjectLinkable (ms_mod ms)
(ml_obj_file loc) t
return (Just l)
_otherwise -> return Nothing
let source_modified | isNothing mb_linkable = SourceModified
| otherwise = SourceUnmodified
hsc_env <- getSession
mod_info <- liftIO $ compileOne' (Just tcg) Nothing
hsc_env ms 1 1 Nothing mb_linkable
source_modified
modifySession $ \e -> e{ hsc_HPT = addToUFM (hsc_HPT e) mod mod_info }
return tcm
data CoreModule
= CoreModule {
cm_module :: !Module,
cm_types :: !TypeEnv,
cm_binds :: CoreProgram,
cm_safe :: SafeHaskellMode
}
instance Outputable CoreModule where
ppr (CoreModule {cm_module = mn, cm_types = te, cm_binds = cb,
cm_safe = sf})
= text "%module" <+> ppr mn <+> parens (ppr sf) <+> ppr te
$$ vcat (map ppr cb)
compileToCoreModule :: GhcMonad m => FilePath -> m CoreModule
compileToCoreModule = compileCore False
compileToCoreSimplified :: GhcMonad m => FilePath -> m CoreModule
compileToCoreSimplified = compileCore True
compileCoreToObj :: GhcMonad m
=> Bool -> CoreModule -> FilePath -> FilePath -> m ()
compileCoreToObj simplify cm@(CoreModule{ cm_module = mName })
output_fn extCore_filename = do
dflags <- getSessionDynFlags
currentTime <- liftIO $ getCurrentTime
cwd <- liftIO $ getCurrentDirectory
modLocation <- liftIO $ mkHiOnlyModLocation dflags (hiSuf dflags) cwd
((moduleNameSlashes . moduleName) mName)
let modSum = ModSummary { ms_mod = mName,
ms_hsc_src = ExtCoreFile,
ms_location = modLocation,
ms_hs_date = currentTime,
ms_obj_date = Nothing,
ms_srcimps = [],
ms_textual_imps = [],
ms_hspp_file = "",
ms_hspp_opts = dflags,
ms_hspp_buf = Nothing
}
hsc_env <- getSession
liftIO $ hscCompileCore hsc_env simplify (cm_safe cm) modSum (cm_binds cm) output_fn extCore_filename
compileCore :: GhcMonad m => Bool -> FilePath -> m CoreModule
compileCore simplify fn = do
target <- guessTarget fn Nothing
addTarget target
_ <- load LoadAllTargets
modGraph <- depanal [] True
case find ((== fn) . msHsFilePath) modGraph of
Just modSummary -> do
mod_guts <- coreModule `fmap`
(desugarModule =<< typecheckModule =<< parseModule modSummary)
liftM (gutsToCoreModule (mg_safe_haskell mod_guts)) $
if simplify
then do
hsc_env <- getSession
simpl_guts <- liftIO $ hscSimplify hsc_env mod_guts
tidy_guts <- liftIO $ tidyProgram hsc_env simpl_guts
return $ Left tidy_guts
else
return $ Right mod_guts
Nothing -> panic "compileToCoreModule: target FilePath not found in\
module dependency graph"
where
gutsToCoreModule :: SafeHaskellMode
-> Either (CgGuts, ModDetails) ModGuts
-> CoreModule
gutsToCoreModule safe_mode (Left (cg, md)) = CoreModule {
cm_module = cg_module cg,
cm_types = md_types md,
cm_binds = cg_binds cg,
cm_safe = safe_mode
}
gutsToCoreModule safe_mode (Right mg) = CoreModule {
cm_module = mg_module mg,
cm_types = typeEnvFromEntities (bindersOfBinds (mg_binds mg))
(mg_tcs mg)
(mg_fam_insts mg),
cm_binds = mg_binds mg,
cm_safe = safe_mode
}
getModuleGraph :: GhcMonad m => m ModuleGraph
getModuleGraph = liftM hsc_mod_graph getSession
needsTemplateHaskell :: ModuleGraph -> Bool
needsTemplateHaskell ms =
any (xopt Opt_TemplateHaskell . ms_hspp_opts) ms
isLoaded :: GhcMonad m => ModuleName -> m Bool
isLoaded m = withSession $ \hsc_env ->
return $! isJust (lookupUFM (hsc_HPT hsc_env) m)
getBindings :: GhcMonad m => m [TyThing]
getBindings = withSession $ \hsc_env ->
return $ icInScopeTTs $ hsc_IC hsc_env
getInsts :: GhcMonad m => m ([ClsInst], [FamInst])
getInsts = withSession $ \hsc_env ->
return $ ic_instances (hsc_IC hsc_env)
getPrintUnqual :: GhcMonad m => m PrintUnqualified
getPrintUnqual = withSession $ \hsc_env ->
return (icPrintUnqual (hsc_dflags hsc_env) (hsc_IC hsc_env))
data ModuleInfo = ModuleInfo {
minf_type_env :: TypeEnv,
minf_exports :: NameSet,
minf_rdr_env :: Maybe GlobalRdrEnv,
minf_instances :: [ClsInst],
minf_iface :: Maybe ModIface,
minf_safe :: SafeHaskellMode
#ifdef GHCI
,minf_modBreaks :: ModBreaks
#endif
}
getModuleInfo :: GhcMonad m => Module -> m (Maybe ModuleInfo)
getModuleInfo mdl = withSession $ \hsc_env -> do
let mg = hsc_mod_graph hsc_env
if mdl `elem` map ms_mod mg
then liftIO $ getHomeModuleInfo hsc_env mdl
else do
liftIO $ getPackageModuleInfo hsc_env mdl
getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
#ifdef GHCI
getPackageModuleInfo hsc_env mdl
= do eps <- hscEPS hsc_env
iface <- hscGetModuleInterface hsc_env mdl
let
avails = mi_exports iface
names = availsToNameSet avails
pte = eps_PTE eps
tys = [ ty | name <- concatMap availNames avails,
Just ty <- [lookupTypeEnv pte name] ]
return (Just (ModuleInfo {
minf_type_env = mkTypeEnv tys,
minf_exports = names,
minf_rdr_env = Just $! availsToGlobalRdrEnv (moduleName mdl) avails,
minf_instances = error "getModuleInfo: instances for package module unimplemented",
minf_iface = Just iface,
minf_safe = getSafeMode $ mi_trust iface,
minf_modBreaks = emptyModBreaks
}))
#else
getPackageModuleInfo _hsc_env _mdl = do
return Nothing
#endif
getHomeModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
getHomeModuleInfo hsc_env mdl =
case lookupUFM (hsc_HPT hsc_env) (moduleName mdl) of
Nothing -> return Nothing
Just hmi -> do
let details = hm_details hmi
iface = hm_iface hmi
return (Just (ModuleInfo {
minf_type_env = md_types details,
minf_exports = availsToNameSet (md_exports details),
minf_rdr_env = mi_globals $! hm_iface hmi,
minf_instances = md_insts details,
minf_iface = Just iface,
minf_safe = getSafeMode $ mi_trust iface
#ifdef GHCI
,minf_modBreaks = getModBreaks hmi
#endif
}))
modInfoTyThings :: ModuleInfo -> [TyThing]
modInfoTyThings minf = typeEnvElts (minf_type_env minf)
modInfoTopLevelScope :: ModuleInfo -> Maybe [Name]
modInfoTopLevelScope minf
= fmap (map gre_name . globalRdrEnvElts) (minf_rdr_env minf)
modInfoExports :: ModuleInfo -> [Name]
modInfoExports minf = nameSetToList $! minf_exports minf
modInfoInstances :: ModuleInfo -> [ClsInst]
modInfoInstances = minf_instances
modInfoIsExportedName :: ModuleInfo -> Name -> Bool
modInfoIsExportedName minf name = elemNameSet name (minf_exports minf)
mkPrintUnqualifiedForModule :: GhcMonad m =>
ModuleInfo
-> m (Maybe PrintUnqualified)
mkPrintUnqualifiedForModule minf = withSession $ \hsc_env -> do
return (fmap (mkPrintUnqualified (hsc_dflags hsc_env)) (minf_rdr_env minf))
modInfoLookupName :: GhcMonad m =>
ModuleInfo -> Name
-> m (Maybe TyThing)
modInfoLookupName minf name = withSession $ \hsc_env -> do
case lookupTypeEnv (minf_type_env minf) name of
Just tyThing -> return (Just tyThing)
Nothing -> do
eps <- liftIO $ readIORef (hsc_EPS hsc_env)
return $! lookupType (hsc_dflags hsc_env)
(hsc_HPT hsc_env) (eps_PTE eps) name
modInfoIface :: ModuleInfo -> Maybe ModIface
modInfoIface = minf_iface
modInfoSafe :: ModuleInfo -> SafeHaskellMode
modInfoSafe = minf_safe
#ifdef GHCI
modInfoModBreaks :: ModuleInfo -> ModBreaks
modInfoModBreaks = minf_modBreaks
#endif
isDictonaryId :: Id -> Bool
isDictonaryId id
= case tcSplitSigmaTy (idType id) of { (_tvs, _theta, tau) -> isDictTy tau }
lookupGlobalName :: GhcMonad m => Name -> m (Maybe TyThing)
lookupGlobalName name = withSession $ \hsc_env -> do
liftIO $ lookupTypeHscEnv hsc_env name
findGlobalAnns :: (GhcMonad m, Typeable a) => ([Word8] -> a) -> AnnTarget Name -> m [a]
findGlobalAnns deserialize target = withSession $ \hsc_env -> do
ann_env <- liftIO $ prepareAnnotations hsc_env Nothing
return (findAnns deserialize ann_env target)
#ifdef GHCI
getGRE :: GhcMonad m => m GlobalRdrEnv
getGRE = withSession $ \hsc_env-> return $ ic_rn_gbl_env (hsc_IC hsc_env)
#endif
packageDbModules :: GhcMonad m =>
Bool
-> 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 ]
dataConType :: DataCon -> Type
dataConType dc = idType (dataConWrapId dc)
pprParenSymName :: NamedThing a => a -> SDoc
pprParenSymName a = parenSymOcc (getOccName a) (ppr (getName a))
#if 0
#endif
getModuleSourceAndFlags :: GhcMonad m => Module -> m (String, StringBuffer, DynFlags)
getModuleSourceAndFlags mod = do
m <- getModSummary (moduleName mod)
case ml_hs_file $ ms_location m of
Nothing -> do dflags <- getDynFlags
liftIO $ throwIO $ mkApiErr dflags (text "No source available for module " <+> ppr mod)
Just sourceFile -> do
source <- liftIO $ hGetStringBuffer sourceFile
return (sourceFile, source, ms_hspp_opts m)
getTokenStream :: GhcMonad m => Module -> m [Located Token]
getTokenStream mod = do
(sourceFile, source, flags) <- getModuleSourceAndFlags mod
let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1
case lexTokenStream source startLoc flags of
POk _ ts -> return ts
PFailed span err ->
do dflags <- getDynFlags
liftIO $ throwIO $ mkSrcErr (unitBag $ mkPlainErrMsg dflags span err)
getRichTokenStream :: GhcMonad m => Module -> m [(Located Token, String)]
getRichTokenStream mod = do
(sourceFile, source, flags) <- getModuleSourceAndFlags mod
let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1
case lexTokenStream source startLoc flags of
POk _ ts -> return $ addSourceToTokens startLoc source ts
PFailed span err ->
do dflags <- getDynFlags
liftIO $ throwIO $ mkSrcErr (unitBag $ mkPlainErrMsg dflags span err)
addSourceToTokens :: RealSrcLoc -> StringBuffer -> [Located Token]
-> [(Located Token, String)]
addSourceToTokens _ _ [] = []
addSourceToTokens loc buf (t@(L span _) : ts)
= case span of
UnhelpfulSpan _ -> (t,"") : addSourceToTokens loc buf ts
RealSrcSpan s -> (t,str) : addSourceToTokens newLoc newBuf ts
where
(newLoc, newBuf, str) = go "" loc buf
start = realSrcSpanStart s
end = realSrcSpanEnd s
go acc loc buf | loc < start = go acc nLoc nBuf
| start <= loc && loc < end = go (ch:acc) nLoc nBuf
| otherwise = (loc, buf, reverse acc)
where (ch, nBuf) = nextChar buf
nLoc = advanceSrcLoc loc ch
showRichTokenStream :: [(Located Token, String)] -> String
showRichTokenStream ts = go startLoc ts ""
where sourceFile = getFile $ map (getLoc . fst) ts
getFile [] = panic "showRichTokenStream: No source file found"
getFile (UnhelpfulSpan _ : xs) = getFile xs
getFile (RealSrcSpan s : _) = srcSpanFile s
startLoc = mkRealSrcLoc sourceFile 1 1
go _ [] = id
go loc ((L span _, str):ts)
= case span of
UnhelpfulSpan _ -> go loc ts
RealSrcSpan s
| locLine == tokLine -> ((replicate (tokCol locCol) ' ') ++)
. (str ++)
. go tokEnd ts
| otherwise -> ((replicate (tokLine locLine) '\n') ++)
. ((replicate (tokCol 1) ' ') ++)
. (str ++)
. go tokEnd ts
where (locLine, locCol) = (srcLocLine loc, srcLocCol loc)
(tokLine, tokCol) = (srcSpanStartLine s, srcSpanStartCol s)
tokEnd = realSrcSpanEnd s
findModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module
findModule mod_name maybe_pkg = withSession $ \hsc_env -> do
let
dflags = hsc_dflags hsc_env
this_pkg = thisPackage dflags
case maybe_pkg of
Just pkg | fsToPackageId pkg /= this_pkg && pkg /= fsLit "this" -> liftIO $ do
res <- findImportedModule hsc_env mod_name maybe_pkg
case res of
Found _ m -> return m
err -> throwOneError $ noModError dflags noSrcSpan mod_name err
_otherwise -> do
home <- lookupLoadedHomeModule mod_name
case home of
Just m -> return m
Nothing -> liftIO $ do
res <- findImportedModule hsc_env mod_name maybe_pkg
case res of
Found loc m | modulePackageId m /= this_pkg -> return m
| otherwise -> modNotLoadedError dflags m loc
err -> throwOneError $ noModError dflags noSrcSpan mod_name err
modNotLoadedError :: DynFlags -> Module -> ModLocation -> IO a
modNotLoadedError dflags m loc = throwGhcExceptionIO $ CmdLineError $ showSDoc dflags $
text "module is not loaded:" <+>
quotes (ppr (moduleName m)) <+>
parens (text (expectJust "modNotLoadedError" (ml_hs_file loc)))
lookupModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module
lookupModule mod_name (Just pkg) = findModule mod_name (Just pkg)
lookupModule mod_name Nothing = withSession $ \hsc_env -> do
home <- lookupLoadedHomeModule mod_name
case home of
Just m -> return m
Nothing -> liftIO $ do
res <- findExposedPackageModule hsc_env mod_name Nothing
case res of
Found _ m -> return m
err -> throwOneError $ noModError (hsc_dflags hsc_env) noSrcSpan mod_name err
lookupLoadedHomeModule :: GhcMonad m => ModuleName -> m (Maybe Module)
lookupLoadedHomeModule mod_name = withSession $ \hsc_env ->
case lookupUFM (hsc_HPT hsc_env) mod_name of
Just mod_info -> return (Just (mi_module (hm_iface mod_info)))
_not_a_home_module -> return Nothing
#ifdef GHCI
isModuleTrusted :: GhcMonad m => Module -> m Bool
isModuleTrusted m = withSession $ \hsc_env ->
liftIO $ hscCheckSafe hsc_env m noSrcSpan
moduleTrustReqs :: GhcMonad m => Module -> m (Bool, [PackageId])
moduleTrustReqs m = withSession $ \hsc_env ->
liftIO $ hscGetSafe hsc_env m noSrcSpan
setGHCiMonad :: GhcMonad m => String -> m ()
setGHCiMonad name = withSession $ \hsc_env -> do
ty <- liftIO $ hscIsGHCiMonad hsc_env name
modifySession $ \s ->
let ic = (hsc_IC s) { ic_monad = ty }
in s { hsc_IC = ic }
getHistorySpan :: GhcMonad m => History -> m SrcSpan
getHistorySpan h = withSession $ \hsc_env ->
return $ InteractiveEval.getHistorySpan hsc_env h
obtainTermFromVal :: GhcMonad m => Int -> Bool -> Type -> a -> m Term
obtainTermFromVal bound force ty a = withSession $ \hsc_env ->
liftIO $ InteractiveEval.obtainTermFromVal hsc_env bound force ty a
obtainTermFromId :: GhcMonad m => Int -> Bool -> Id -> m Term
obtainTermFromId bound force id = withSession $ \hsc_env ->
liftIO $ InteractiveEval.obtainTermFromId hsc_env bound force id
#endif
lookupName :: GhcMonad m => Name -> m (Maybe TyThing)
lookupName name =
withSession $ \hsc_env ->
liftIO $ hscTcRcLookupName hsc_env name
parser :: String
-> DynFlags
-> FilePath
-> Either ErrorMessages (WarningMessages, Located (HsModule RdrName))
parser str dflags filename =
let
loc = mkRealSrcLoc (mkFastString filename) 1 1
buf = stringToStringBuffer str
in
case unP Parser.parseModule (mkPState dflags buf loc) of
PFailed span err ->
Left (unitBag (mkPlainErrMsg dflags span err))
POk pst rdr_module ->
let (warns,_) = getMessages pst in
Right (warns, rdr_module)