module GHC (
defaultErrorHandler,
defaultCleanupHandler,
prettyPrintGhcErrors,
withSignalHandlers,
withCleanupSession,
Ghc, GhcT, GhcMonad(..), HscEnv,
runGhc, runGhcT, initGhcMonad,
printException,
handleSourceError,
needsTemplateHaskellOrQQ,
DynFlags(..), GeneralFlag(..), Severity(..), HscTarget(..), gopt,
GhcMode(..), GhcLink(..), defaultObjectTarget,
parseDynamicFlags,
getSessionDynFlags, setSessionDynFlags,
getProgramDynFlags, setProgramDynFlags, setLogAction,
getInteractiveDynFlags, setInteractiveDynFlags,
interpretPackageEnv,
Target(..), TargetId(..), Phase,
setTargets,
getTargets,
addTarget,
removeTarget,
guessTarget,
depanal, depanalE,
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,
ModuleGraph, emptyMG, mapMG, mkModuleGraph, mgModSummaries,
mgLookupModule,
ModSummary(..), ms_mod_name, ModLocation(..),
getModSummary,
getModuleGraph,
isLoaded,
topSortModuleGraph,
ModuleInfo,
getModuleInfo,
modInfoTyThings,
modInfoTopLevelScope,
modInfoExports,
modInfoExportsWithSelectors,
modInfoInstances,
modInfoIsExportedName,
modInfoLookupName,
modInfoIface,
modInfoRdrEnv,
modInfoSafe,
lookupGlobalName,
findGlobalAnns,
mkPrintUnqualifiedForModule,
ModIface, ModIface_(..),
SafeHaskellMode(..),
PrintUnqualified, alwaysQualify,
execStmt, execStmt', ExecOptions(..), execOptions, ExecResult(..),
resumeExec,
runDecls, runDeclsWithLocation, runParsedDecls,
parseImportDecl,
setContext, getContext,
setGHCiMonad, getGHCiMonad,
getBindings, getInsts, getPrintUnqual,
findModule, lookupModule,
isModuleTrusted, moduleTrustReqs,
getNamesInScope,
getRdrNamesInScope,
getGRE,
moduleIsInterpreted,
getInfo,
showModule,
moduleIsBootOrNotObjectLinkable,
getNameToInstancesIndex,
exprType, TcRnExprMode(..),
typeKind,
parseName,
lookupName,
HValue, parseExpr, compileParsedExpr,
GHC.Runtime.Eval.compileExpr, dynCompileExpr,
ForeignHValue,
compileExprRemote, compileParsedExprRemote,
getDocs, GetDocsFailure(..),
runTcInteractive,
isStmt, hasImport, isImport, isDecl,
SingleStep(..),
Resume(..),
History(historyBreakInfo, historyEnclosingDecls),
GHC.getHistorySpan, getHistoryModule,
abandon, abandonAll,
getResumeContext,
GHC.obtainTermFromId, GHC.obtainTermFromVal, reconstructType,
modInfoModBreaks,
ModBreaks(..), BreakIndex,
BreakInfo(breakInfo_number, breakInfo_module),
GHC.Runtime.Eval.back,
GHC.Runtime.Eval.forward,
Unit,
Module, mkModule, pprModule, moduleName, moduleUnit,
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,
isDeadEndId, isDictonaryId,
recordSelectorTyCon,
TyCon,
tyConTyVars, tyConDataCons, tyConArity,
isClassTyCon, isTypeSynonymTyCon, isTypeFamilyTyCon, isNewTyCon,
isPrimTyCon, isFunTyCon,
isFamilyTyCon, isOpenFamilyTyCon, isOpenTypeFamilyTyCon,
tyConClass_maybe,
synTyConRhs_maybe, synTyConDefn_maybe, tyConKind,
TyVar,
alphaTyVars,
DataCon,
dataConType, dataConTyCon, dataConFieldLabels,
dataConIsInfix, isVanillaDataCon, dataConWrapperType,
dataConSrcBangs,
StrictnessMark(..), isMarkedStrict,
Class,
classMethods, classSCTheta, classTvsFds, classATs,
pprFundeps,
ClsInst,
instanceDFunId,
pprInstance, pprInstanceHdr,
pprFamInst,
FamInst,
Type, splitForAllTys, funResultTy,
pprParendType, pprTypeApp,
Kind,
PredType,
ThetaType, pprForAll, pprThetaArrowTy,
parseInstanceHead,
getInstancesForType,
TyThing(..),
module GHC.Hs,
FixityDirection(..),
defaultFixity, maxPrecedence,
negateFixity,
compareFixity,
LexicalFixity(..),
SrcLoc(..), RealSrcLoc,
mkSrcLoc, noSrcLoc,
srcLocFile, srcLocLine, srcLocCol,
SrcSpan(..), RealSrcSpan,
mkSrcSpan, srcLocSpan, isGoodSrcSpan, noSrcSpan,
srcSpanStart, srcSpanEnd,
srcSpanFile,
srcSpanStartLine, srcSpanEndLine,
srcSpanStartCol, srcSpanEndCol,
GenLocated(..), Located, RealLocated,
noLoc, mkGeneralLocated,
getLoc, unLoc,
getRealSrcSpan, unRealSrcSpan,
eqLocated, cmpLocated, combineLocs, addCLoc,
leftmost_smallest, leftmost_largest, rightmost_smallest,
spans, isSubspanOf,
GhcException(..), showGhcException,
Token,
getTokenStream, getRichTokenStream,
showRichTokenStream, addSourceToTokens,
parser,
ApiAnns(..),AnnKeywordId(..),AnnotationComment(..), ApiAnnKey,
getAnnotation, getAndRemoveAnnotation,
getAnnotationComments, getAndRemoveAnnotationComments,
unicodeAnn,
--sessionHscEnv,
cyclicModuleErr,
) where
#include "HsVersions.h"
import GHC.Prelude hiding (init)
import GHC.ByteCode.Types
import GHC.Runtime.Eval
import GHC.Runtime.Eval.Types
import GHC.Runtime.Interpreter
import GHC.Runtime.Interpreter.Types
import GHCi.RemoteTypes
import GHC.Core.Ppr.TyThing ( pprFamInst )
import GHC.Driver.Main
import GHC.Driver.Make
import GHC.Driver.Hooks
import GHC.Driver.Pipeline ( compileOne' )
import GHC.Driver.Monad
import GHC.Tc.Utils.Monad ( finalSafeMode, fixSafeInstances, initIfaceTcRn )
import GHC.Iface.Load ( loadSysInterface )
import GHC.Tc.Types
import GHC.Core.Predicate
import GHC.Unit.State
import GHC.Types.Name.Set
import GHC.Types.Name.Reader
import GHC.Hs
import GHC.Core.Type hiding( typeKind )
import GHC.Tc.Utils.TcType
import GHC.Types.Id
import GHC.Builtin.Types.Prim ( alphaTyVars )
import GHC.Core.TyCon
import GHC.Core.TyCo.Ppr ( pprForAll )
import GHC.Core.Class
import GHC.Core.DataCon
import GHC.Core.FVs ( orphNamesOfFamInst )
import GHC.Core.FamInstEnv ( FamInst, famInstEnvElts )
import GHC.Core.InstEnv
import GHC.Types.Name hiding ( varName )
import GHC.Types.Avail
import GHC.Types.SrcLoc
import GHC.Core
import GHC.Iface.Tidy
import GHC.Driver.Phases ( Phase(..), isHaskellSrcFilename )
import GHC.Driver.Finder
import GHC.Driver.Types
import GHC.Driver.CmdLine
import GHC.Driver.Session hiding (WarnReason(..))
import GHC.Driver.Ways
import GHC.SysTools
import GHC.SysTools.BaseDir
import GHC.Types.Annotations
import GHC.Unit.Module
import GHC.Utils.Panic
import GHC.Platform
import GHC.Data.Bag ( listToBag )
import GHC.Utils.Error
import GHC.Utils.Monad
import GHC.Utils.Misc
import GHC.Data.StringBuffer
import GHC.Utils.Outputable
import GHC.Types.Basic
import GHC.Data.FastString
import qualified GHC.Parser as Parser
import GHC.Parser.Lexer
import GHC.Parser.Annotation
import qualified GHC.LanguageExtensions as LangExt
import GHC.Types.Name.Env
import GHC.Tc.Module
import GHC.Tc.Utils.Instantiate
import GHC.Tc.Instance.Family
import GHC.SysTools.FileCleanup
import Data.Foldable
import qualified Data.Map.Strict as Map
import Data.Set (Set)
import qualified Data.Set as S
import qualified Data.Sequence as Seq
import Data.Maybe
import Data.Time
import Data.Typeable ( Typeable )
import Data.Word ( Word8 )
import Control.Monad
import System.Exit ( exitWith, ExitCode(..) )
import GHC.Utils.Exception
import Data.IORef
import System.FilePath
import Control.Concurrent
import Control.Applicative ((<|>))
import Control.Monad.Catch as MC
import GHC.Data.Maybe
import System.IO.Error ( isDoesNotExistError )
import System.Environment ( getEnv )
import System.Directory
defaultErrorHandler :: (ExceptionMonad m)
=> FatalMessager -> FlushOut -> m a -> m a
defaultErrorHandler fm (FlushOut flushOut) inner =
MC.handle (\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
Signal _ -> exitWith (ExitFailure 1)
_ -> do fatalErrorMsg'' fm (show ge)
exitWith (ExitFailure 1)
) $
inner
defaultCleanupHandler :: (ExceptionMonad m) => DynFlags -> m a -> m a
defaultCleanupHandler _ m = m
where _warning_suppression = m `MC.onException` undefined
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 $ withSignalHandlers $ do
initGhcMonad mb_top_dir
withCleanupSession ghc
runGhcT :: ExceptionMonad 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 $ withSignalHandlers $ do
initGhcMonad mb_top_dir
withCleanupSession ghct
withCleanupSession :: GhcMonad m => m a -> m a
withCleanupSession ghc = ghc `MC.finally` cleanup
where
cleanup = do
hsc_env <- getSession
let dflags = hsc_dflags hsc_env
liftIO $ do
cleanTempFiles dflags
cleanTempDirs dflags
stopInterp hsc_env
initGhcMonad :: GhcMonad m => Maybe FilePath -> m ()
initGhcMonad mb_top_dir
= do { env <- liftIO $
do { top_dir <- findTopDir mb_top_dir
; mySettings <- initSysTools top_dir
; myLlvmConfig <- lazyInitLlvmConfig top_dir
; dflags <- initDynFlags (defaultDynFlags mySettings myLlvmConfig)
; 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
; liftIO $ 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 `S.notMember` ways dflags = return False
| not tablesNextToCode = return False
| otherwise = do
linkerInfo <- liftIO $ getLinkerInfo dflags
case linkerInfo of
GnuLD _ -> return True
_ -> return False
where platform = targetPlatform dflags
arch = platformArch platform
tablesNextToCode = platformTablesNextToCode platform
setSessionDynFlags :: GhcMonad m => DynFlags -> m ()
setSessionDynFlags dflags = do
dflags' <- checkNewDynFlags dflags
dflags''' <- liftIO $ initUnits dflags'
interp <- if gopt Opt_ExternalInterpreter dflags
then do
let
prog = pgm_i dflags ++ flavour
profiled = ways dflags `hasWay` WayProf
dynamic = ways dflags `hasWay` WayDyn
flavour
| profiled = "-prof"
| dynamic = "-dyn"
| otherwise = ""
msg = text "Starting " <> text prog
tr <- if verbosity dflags >= 3
then return (logInfo dflags $ withPprStyle defaultDumpStyle msg)
else return (pure ())
let
conf = IServConfig
{ iservConfProgram = prog
, iservConfOpts = getOpts dflags opt_i
, iservConfProfiled = profiled
, iservConfDynamic = dynamic
, iservConfHook = createIservProcessHook (hooks dflags)
, iservConfTrace = tr
}
s <- liftIO $ newMVar IServPending
return (Just (ExternalInterp conf (IServ s)))
else
#if defined(HAVE_INTERNAL_INTERPRETER)
return (Just InternalInterp)
#else
return Nothing
#endif
modifySession $ \h -> h{ hsc_dflags = dflags'''
, hsc_IC = (hsc_IC h){ ic_dflags = dflags''' }
, hsc_interp = hsc_interp h <|> interp
}
invalidateModSummaryCache
setProgramDynFlags :: GhcMonad m => DynFlags -> m Bool
setProgramDynFlags dflags = setProgramDynFlags_ True dflags
setLogAction :: GhcMonad m => LogAction -> m ()
setLogAction action = do
dflags' <- getProgramDynFlags
void $ setProgramDynFlags_ False $
dflags' { log_action = action }
setProgramDynFlags_ :: GhcMonad m => Bool -> DynFlags -> m Bool
setProgramDynFlags_ invalidate_needed dflags = do
dflags' <- checkNewDynFlags dflags
dflags_prev <- getProgramDynFlags
let changed = packageFlagsChanged dflags_prev dflags'
dflags'' <- if changed
then liftIO $ initUnits dflags'
else return dflags'
modifySession $ \h -> h{ hsc_dflags = dflags'' }
when invalidate_needed $ invalidateModSummaryCache
return changed
invalidateModSummaryCache :: GhcMonad m => m ()
invalidateModSummaryCache =
modifySession $ \h -> h { hsc_mod_graph = mapMG 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
dflags' <- checkNewDynFlags dflags
dflags'' <- checkNewInteractiveDynFlags dflags'
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], [Warn])
parseDynamicFlags dflags cmdline = do
(dflags1, leftovers, warns) <- parseDynamicFlagsCmdLine dflags cmdline
dflags2 <- liftIO $ interpretPackageEnv dflags1
return (dflags2, leftovers, warns)
checkNewDynFlags :: MonadIO m => DynFlags -> m DynFlags
checkNewDynFlags dflags = do
let (dflags', warnings) = makeDynFlagsConsistent dflags
liftIO $ handleFlagWarnings dflags (map (Warn NoReason) warnings)
return dflags'
checkNewInteractiveDynFlags :: MonadIO m => DynFlags -> m DynFlags
checkNewInteractiveDynFlags dflags0 = do
if xopt LangExt.StaticPointers dflags0
then do liftIO $ printOrThrowWarnings dflags0 $ listToBag
[mkPlainWarnMsg dflags0 interactiveSrcSpan
$ text "StaticPointers is not supported in GHCi interactive expressions."]
return $ xopt_unset dflags0 LangExt.StaticPointers
else return dflags0
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]
, pm_annotations :: ApiAnns }
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
type RenamedSource = (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [(LIE GhcRn, Avails)],
Maybe LHsDocString)
type TypecheckedSource = LHsBinds GhcTc
getModSummary :: GhcMonad m => ModuleName -> m ModSummary
getModSummary mod = do
mg <- liftM hsc_mod_graph getSession
let mods_by_name = [ ms | ms <- mgModSummaries mg
, ms_mod_name ms == mod
, isBootSummary ms == NotBoot ]
case mods_by_name 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)
(hpm_annotations 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,
hpm_annotations = pm_annotations 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 = md_exports details,
minf_rdr_env = Just (tcg_rdr_env tc_gbl_env),
minf_instances = fixSafeInstances safe $ md_insts details,
minf_iface = Nothing,
minf_safe = safe,
minf_modBreaks = emptyModBreaks
}}
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 = addToHpt (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
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) (mgModSummaries modGraph) of
Just modSummary -> do
(tcg, mod_guts) <-
do tm <- typecheckModule =<< parseModule modSummary
let tcg = fst (tm_internals tm)
(,) tcg . coreModule <$> desugarModule tm
liftM (gutsToCoreModule (mg_safe_haskell mod_guts)) $
if simplify
then do
hsc_env <- getSession
simpl_guts <- liftIO $ do
plugins <- readIORef (tcg_th_coreplugins tcg)
hscSimplify hsc_env plugins 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
isLoaded :: GhcMonad m => ModuleName -> m Bool
isLoaded m = withSession $ \hsc_env ->
return $! isJust (lookupHpt (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 :: [AvailInfo],
minf_rdr_env :: Maybe GlobalRdrEnv,
minf_instances :: [ClsInst],
minf_iface :: Maybe ModIface,
minf_safe :: SafeHaskellMode,
minf_modBreaks :: ModBreaks
}
getModuleInfo :: GhcMonad m => Module -> m (Maybe ModuleInfo)
getModuleInfo mdl = withSession $ \hsc_env -> do
let mg = hsc_mod_graph hsc_env
if mgElemModule mg mdl
then liftIO $ getHomeModuleInfo hsc_env mdl
else do
liftIO $ getPackageModuleInfo hsc_env mdl
getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
getPackageModuleInfo hsc_env mdl
= do eps <- hscEPS hsc_env
iface <- hscGetModuleInterface hsc_env mdl
let
avails = mi_exports iface
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 = avails,
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
}))
getHomeModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
getHomeModuleInfo hsc_env mdl =
case lookupHpt (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 = 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
,minf_modBreaks = getModBreaks hmi
}))
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 = concatMap availNames $! minf_exports minf
modInfoExportsWithSelectors :: ModuleInfo -> [Name]
modInfoExportsWithSelectors minf = concatMap availNamesWithSelectors $! minf_exports minf
modInfoInstances :: ModuleInfo -> [ClsInst]
modInfoInstances = minf_instances
modInfoIsExportedName :: ModuleInfo -> Name -> Bool
modInfoIsExportedName minf name = elemNameSet name (availsToNameSet (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
modInfoRdrEnv :: ModuleInfo -> Maybe GlobalRdrEnv
modInfoRdrEnv = minf_rdr_env
modInfoSafe :: ModuleInfo -> SafeHaskellMode
modInfoSafe = minf_safe
modInfoModBreaks :: ModuleInfo -> ModBreaks
modInfoModBreaks = minf_modBreaks
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)
getGRE :: GhcMonad m => m GlobalRdrEnv
getGRE = withSession $ \hsc_env-> return $ ic_rn_gbl_env (hsc_IC hsc_env)
getNameToInstancesIndex :: GhcMonad m
=> [Module]
-> Maybe [Module]
-> m (Messages, Maybe (NameEnv ([ClsInst], [FamInst])))
getNameToInstancesIndex visible_mods mods_to_load = do
hsc_env <- getSession
liftIO $ runTcInteractive hsc_env $
do { case mods_to_load of
Nothing -> loadUnqualIfaces hsc_env (hsc_IC hsc_env)
Just mods ->
let doc = text "Need interface for reporting instances in scope"
in initIfaceTcRn $ mapM_ (loadSysInterface doc) mods
; InstEnvs {ie_global, ie_local} <- tcGetInstEnvs
; let visible_mods' = mkModuleSet visible_mods
; (pkg_fie, home_fie) <- tcGetFamInstEnvs
; let cls_index = Map.fromListWith mappend
[ (n, Seq.singleton ispec)
| ispec <- instEnvElts ie_local ++ instEnvElts ie_global
, instIsVisible visible_mods' ispec
, n <- nameSetElemsStable $ orphNamesOfClsInst ispec
]
; let fam_index = Map.fromListWith mappend
[ (n, Seq.singleton fispec)
| fispec <- famInstEnvElts home_fie ++ famInstEnvElts pkg_fie
, n <- nameSetElemsStable $ orphNamesOfFamInst fispec
]
; return $ mkNameEnv $
[ (nm, (toList clss, toList fams))
| (nm, (clss, fams)) <- Map.toList $ Map.unionWith mappend
(fmap (,Seq.empty) cls_index)
(fmap (Seq.empty,) fam_index)
] }
dataConType :: DataCon -> Type
dataConType dc = idType (dataConWrapId dc)
pprParenSymName :: NamedThing a => a -> SDoc
pprParenSymName a = parenSymOcc (getOccName a) (ppr (getName a))
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 pst ->
do dflags <- getDynFlags
throwErrors (getErrorMessages pst dflags)
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 pst ->
do dflags <- getDynFlags
throwErrors (getErrorMessages pst dflags)
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 = homeUnit dflags
case maybe_pkg of
Just pkg | fsToUnit 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 | moduleUnit 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 lookupHpt (hsc_HPT hsc_env) mod_name of
Just mod_info -> return (Just (mi_module (hm_iface mod_info)))
_not_a_home_module -> return Nothing
isModuleTrusted :: GhcMonad m => Module -> m Bool
isModuleTrusted m = withSession $ \hsc_env ->
liftIO $ hscCheckSafe hsc_env m noSrcSpan
moduleTrustReqs :: GhcMonad m => Module -> m (Bool, Set UnitId)
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 }
getGHCiMonad :: GhcMonad m => m Name
getGHCiMonad = fmap (ic_monad . hsc_IC) getSession
getHistorySpan :: GhcMonad m => History -> m SrcSpan
getHistorySpan h = withSession $ \hsc_env ->
return $ GHC.Runtime.Eval.getHistorySpan hsc_env h
obtainTermFromVal :: GhcMonad m => Int -> Bool -> Type -> a -> m Term
obtainTermFromVal bound force ty a = withSession $ \hsc_env ->
liftIO $ GHC.Runtime.Eval.obtainTermFromVal hsc_env bound force ty a
obtainTermFromId :: GhcMonad m => Int -> Bool -> Id -> m Term
obtainTermFromId bound force id = withSession $ \hsc_env ->
liftIO $ GHC.Runtime.Eval.obtainTermFromId hsc_env bound force id
lookupName :: GhcMonad m => Name -> m (Maybe TyThing)
lookupName name =
withSession $ \hsc_env ->
liftIO $ hscTcRcLookupName hsc_env name
parser :: String
-> DynFlags
-> FilePath
-> (WarningMessages, Either ErrorMessages (Located HsModule))
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 pst ->
let (warns,errs) = getMessages pst dflags in
(warns, Left errs)
POk pst rdr_module ->
let (warns,_) = getMessages pst dflags in
(warns, Right rdr_module)
interpretPackageEnv :: DynFlags -> IO DynFlags
interpretPackageEnv dflags = do
mPkgEnv <- runMaybeT $ msum $ [
getCmdLineArg >>= \env -> msum [
probeNullEnv env
, probeEnvFile env
, probeEnvName env
, cmdLineError env
]
, getEnvVar >>= \env -> msum [
probeNullEnv env
, probeEnvFile env
, probeEnvName env
, envError env
]
, notIfHideAllPackages >> msum [
findLocalEnvFile >>= probeEnvFile
, probeEnvName defaultEnvName
]
]
case mPkgEnv of
Nothing ->
return dflags
Just "-" -> do
return dflags
Just envfile -> do
content <- readFile envfile
compilationProgressMsg dflags ("Loaded package environment from " ++ envfile)
let (_, dflags') = runCmdLine (runEwM (setFlagsFromEnvFile envfile content)) dflags
return dflags'
where
platformArchOs = platformMini (targetPlatform dflags)
namedEnvPath :: String -> MaybeT IO FilePath
namedEnvPath name = do
appdir <- versionedAppDir (programName dflags) platformArchOs
return $ appdir </> "environments" </> name
probeEnvName :: String -> MaybeT IO FilePath
probeEnvName name = probeEnvFile =<< namedEnvPath name
probeEnvFile :: FilePath -> MaybeT IO FilePath
probeEnvFile path = do
guard =<< liftMaybeT (doesFileExist path)
return path
probeNullEnv :: FilePath -> MaybeT IO FilePath
probeNullEnv "-" = return "-"
probeNullEnv _ = mzero
getCmdLineArg :: MaybeT IO String
getCmdLineArg = MaybeT $ return $ packageEnv dflags
getEnvVar :: MaybeT IO String
getEnvVar = do
mvar <- liftMaybeT $ MC.try $ getEnv "GHC_ENVIRONMENT"
case mvar of
Right var -> return var
Left err -> if isDoesNotExistError err then mzero
else liftMaybeT $ throwIO err
notIfHideAllPackages :: MaybeT IO ()
notIfHideAllPackages =
guard (not (gopt Opt_HideAllPackages dflags))
defaultEnvName :: String
defaultEnvName = "default"
localEnvFileName :: FilePath
localEnvFileName = ".ghc.environment" <.> versionedFilePath platformArchOs
findLocalEnvFile :: MaybeT IO FilePath
findLocalEnvFile = do
curdir <- liftMaybeT getCurrentDirectory
homedir <- tryMaybeT getHomeDirectory
let probe dir | isDrive dir || dir == homedir
= mzero
probe dir = do
let file = dir </> localEnvFileName
exists <- liftMaybeT (doesFileExist file)
if exists
then return file
else probe (takeDirectory dir)
probe curdir
cmdLineError :: String -> MaybeT IO a
cmdLineError env = liftMaybeT . throwGhcExceptionIO . CmdLineError $
"Package environment " ++ show env ++ " not found"
envError :: String -> MaybeT IO a
envError env = liftMaybeT . throwGhcExceptionIO . CmdLineError $
"Package environment "
++ show env
++ " (specified in GHC_ENVIRONMENT) not found"