module GHC (
defaultErrorHandler,
defaultCleanupHandler,
prettyPrintGhcErrors,
withSignalHandlers,
withCleanupSession,
Ghc, GhcT, GhcMonad(..), HscEnv,
runGhc, runGhcT, initGhcMonad,
printException,
handleSourceError,
DynFlags(..), GeneralFlag(..), Severity(..), Backend(..), gopt,
GhcMode(..), GhcLink(..),
parseDynamicFlags, parseTargetFiles,
getSessionDynFlags,
setTopSessionDynFlags,
setSessionDynFlags,
setUnitDynFlags,
getProgramDynFlags, setProgramDynFlags,
getInteractiveDynFlags, setInteractiveDynFlags,
interpretPackageEnv,
Logger, getLogger,
pushLogHook, popLogHook,
pushLogHookM, popLogHookM, modifyLogger,
putMsgM, putLogMsgM,
Target(..), TargetId(..), Phase,
setTargets,
getTargets,
addTarget,
removeTarget,
guessTarget,
depanal, depanalE,
load, loadWithCache, LoadHowMuch(..), InteractiveImport(..),
SuccessFlag(..), succeeded, failed,
defaultWarnErrLogger, WarnErrLogger,
workingDirectoryChanged,
parseModule, typecheckModule, desugarModule,
ParsedModule(..), TypecheckedModule(..), DesugaredModule(..),
TypecheckedSource, ParsedSource, RenamedSource,
TypecheckedMod, ParsedMod,
moduleInfo, renamedSource, typecheckedSource,
parsedSource, coreModule,
PkgQual(..),
CoreModule(..),
compileToCoreModule, compileToCoreSimplified,
ModuleGraph, emptyMG, mapMG, mkModuleGraph, mgModSummaries,
mgLookupModule,
ModSummary(..), ms_mod_name, ModLocation(..),
getModSummary,
getModuleGraph,
isLoaded,
isLoadedModule,
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,
findQualifiedModule, lookupQualifiedModule,
renamePkgQualM, renameRawPkgQualM,
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(..),
GHC.Runtime.Eval.back,
GHC.Runtime.Eval.forward,
GHC.Runtime.Eval.setupBreakpoint,
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, splitForAllTyCoVars, 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,
GhcApiError(..),
Token,
getTokenStream, getRichTokenStream,
showRichTokenStream, addSourceToTokens,
parser,
AnnKeywordId(..),EpaComment(..),
--sessionHscEnv,
cyclicModuleErr,
) where
import GHC.Prelude hiding (init)
import GHC.Platform
import GHC.Platform.Ways
import GHC.Driver.Phases ( Phase(..), isHaskellSrcFilename
, isSourceFilename, startPhase )
import GHC.Driver.Env
import GHC.Driver.Errors
import GHC.Driver.Errors.Types
import GHC.Driver.CmdLine
import GHC.Driver.Session
import GHC.Driver.Backend
import GHC.Driver.Config.Finder (initFinderOpts)
import GHC.Driver.Config.Parser (initParserOpts)
import GHC.Driver.Config.Logger (initLogFlags)
import GHC.Driver.Config.Diagnostic
import GHC.Driver.Main
import GHC.Driver.Make
import GHC.Driver.Hooks
import GHC.Driver.Monad
import GHC.Driver.Ppr
import GHC.ByteCode.Types
import qualified GHC.Linker.Loader as Loader
import GHC.Runtime.Loader
import GHC.Runtime.Eval
import GHC.Runtime.Interpreter
import GHC.Runtime.Context
import GHCi.RemoteTypes
import qualified GHC.Parser as Parser
import GHC.Parser.Lexer
import GHC.Parser.Annotation
import GHC.Parser.Utils
import GHC.Iface.Load ( loadSysInterface )
import GHC.Hs
import GHC.Builtin.Types.Prim ( alphaTyVars )
import GHC.Data.StringBuffer
import GHC.Data.FastString
import qualified GHC.LanguageExtensions as LangExt
import GHC.Rename.Names (renamePkgQual, renameRawPkgQual)
import GHC.Tc.Utils.Monad ( finalSafeMode, fixSafeInstances, initIfaceTcRn )
import GHC.Tc.Types
import GHC.Tc.Utils.TcType
import GHC.Tc.Module
import GHC.Tc.Utils.Instantiate
import GHC.Tc.Instance.Family
import GHC.Utils.TmpFs
import GHC.SysTools
import GHC.SysTools.BaseDir
import GHC.Utils.Error
import GHC.Utils.Monad
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Utils.Logger
import GHC.Utils.Fingerprint
import GHC.Core.Predicate
import GHC.Core.Type hiding( typeKind )
import GHC.Core.TyCon
import GHC.Core.TyCo.Ppr ( pprForAll )
import GHC.Core.Class
import GHC.Core.DataCon
import GHC.Core.FVs ( orphNamesOfFamInst )
import GHC.Core.FamInstEnv ( FamInst, famInstEnvElts )
import GHC.Core.InstEnv
import GHC.Core
import GHC.Types.Id
import GHC.Types.Name hiding ( varName )
import GHC.Types.Avail
import GHC.Types.SrcLoc
import GHC.Types.TyThing.Ppr ( pprFamInst )
import GHC.Types.Annotations
import GHC.Types.Name.Set
import GHC.Types.Name.Reader
import GHC.Types.SourceError
import GHC.Types.SafeHaskell
import GHC.Types.Error
import GHC.Types.Fixity
import GHC.Types.Target
import GHC.Types.Basic
import GHC.Types.TyThing
import GHC.Types.Name.Env
import GHC.Types.Name.Ppr
import GHC.Types.TypeEnv
import GHC.Types.BreakInfo
import GHC.Types.PkgQual
import GHC.Unit
import GHC.Unit.Env
import GHC.Unit.External
import GHC.Unit.Finder
import GHC.Unit.Module.ModIface
import GHC.Unit.Module.ModGuts
import GHC.Unit.Module.ModDetails
import GHC.Unit.Module.ModSummary
import GHC.Unit.Module.Graph
import GHC.Unit.Home.ModInfo
import Data.Foldable
import qualified Data.Map.Strict as Map
import Data.Set (Set)
import qualified Data.Sequence as Seq
import Data.Maybe
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, getProgName )
import System.Directory
import Data.List (isPrefixOf)
import qualified Data.Set as S
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) ->
fm (show ioe)
_ -> case fromException exception of
Just UserInterrupt ->
liftIO $ throwIO UserInterrupt
Just StackOverflow ->
fm "stack overflow: use +RTS -K<size> to increase it"
_ -> case fromException exception of
Just (ex :: ExitCode) -> liftIO $ throwIO ex
_ ->
fm (show (Panic (show exception)))
exitWith (ExitFailure 1)
) $
handleGhcException
(\ge -> liftIO $ do
flushOut
case ge of
Signal _ -> return ()
ProgramError _ -> fm (show ge)
CmdLineError _ -> fm ("<command line>: " ++ show ge)
_ -> do
progName <- getProgName
fm (progName ++ ": " ++ 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
let logger = hsc_logger hsc_env
let tmpfs = hsc_tmpfs hsc_env
liftIO $ do
unless (gopt Opt_KeepTmpFiles dflags) $ do
cleanTempFiles logger tmpfs
cleanTempDirs logger tmpfs
traverse_ stopInterp (hsc_interp hsc_env)
initGhcMonad :: GhcMonad m => Maybe FilePath -> m ()
initGhcMonad mb_top_dir
= do {
!keep_cafs <- liftIO $ c_keepCAFsForGHCi
; massert keep_cafs
; env <- liftIO $
do { top_dir <- findTopDir mb_top_dir
; mySettings <- initSysTools top_dir
; myLlvmConfig <- lazyInitLlvmConfig top_dir
; dflags <- initDynFlags (defaultDynFlags mySettings myLlvmConfig)
; hsc_env <- newHscEnv dflags
; checkBrokenTablesNextToCode (hsc_logger hsc_env) dflags
; setUnsafeGlobalDynFlags dflags
; return hsc_env }
; setSession env }
checkBrokenTablesNextToCode :: MonadIO m => Logger -> DynFlags -> m ()
checkBrokenTablesNextToCode logger dflags
= do { broken <- checkBrokenTablesNextToCode' logger 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 => Logger -> DynFlags -> m Bool
checkBrokenTablesNextToCode' logger dflags
| not (isARM arch) = return False
| ways dflags `hasNotWay` WayDyn = return False
| not tablesNextToCode = return False
| otherwise = do
linkerInfo <- liftIO $ getLinkerInfo logger dflags
case linkerInfo of
GnuLD _ -> return True
_ -> return False
where platform = targetPlatform dflags
arch = platformArch platform
tablesNextToCode = platformTablesNextToCode platform
setSessionDynFlags :: (HasCallStack, GhcMonad m) => DynFlags -> m ()
setSessionDynFlags dflags0 = do
hsc_env <- getSession
logger <- getLogger
dflags <- checkNewDynFlags logger dflags0
let all_uids = hsc_all_home_unit_ids hsc_env
case S.toList all_uids of
[uid] -> do
setUnitDynFlagsNoCheck uid dflags
modifySession (hscSetActiveUnitId (homeUnitId_ dflags))
dflags' <- getDynFlags
setTopSessionDynFlags dflags'
[] -> panic "nohue"
_ -> panic "setSessionDynFlags can only be used with a single home unit"
setUnitDynFlags :: GhcMonad m => UnitId -> DynFlags -> m ()
setUnitDynFlags uid dflags0 = do
logger <- getLogger
dflags1 <- checkNewDynFlags logger dflags0
setUnitDynFlagsNoCheck uid dflags1
setUnitDynFlagsNoCheck :: GhcMonad m => UnitId -> DynFlags -> m ()
setUnitDynFlagsNoCheck uid dflags1 = do
logger <- getLogger
hsc_env <- getSession
let old_hue = ue_findHomeUnitEnv uid (hsc_unit_env hsc_env)
let cached_unit_dbs = homeUnitEnv_unit_dbs old_hue
(dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 cached_unit_dbs (hsc_all_home_unit_ids hsc_env)
updated_dflags <- liftIO $ updatePlatformConstants dflags1 mconstants
let upd hue =
hue
{ homeUnitEnv_units = unit_state
, homeUnitEnv_unit_dbs = Just dbs
, homeUnitEnv_dflags = updated_dflags
, homeUnitEnv_home_unit = Just home_unit
}
let unit_env = ue_updateHomeUnitEnv upd uid (hsc_unit_env hsc_env)
let dflags = updated_dflags
let unit_env0 = unit_env
{ ue_platform = targetPlatform dflags
, ue_namever = ghcNameVersion dflags
}
let !unit_env1 =
if homeUnitId_ dflags /= uid
then
ue_renameUnitId
uid
(homeUnitId_ dflags)
unit_env0
else unit_env0
modifySession $ \h -> h{ hsc_unit_env = unit_env1
}
invalidateModSummaryCache
setTopSessionDynFlags :: GhcMonad m => DynFlags -> m ()
setTopSessionDynFlags dflags = do
hsc_env <- getSession
logger <- getLogger
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 logger $ withPprStyle defaultDumpStyle msg)
else return (pure ())
let
conf = IServConfig
{ iservConfProgram = prog
, iservConfOpts = getOpts dflags opt_i
, iservConfProfiled = profiled
, iservConfDynamic = dynamic
, iservConfHook = createIservProcessHook (hsc_hooks hsc_env)
, iservConfTrace = tr
}
s <- liftIO $ newMVar IServPending
loader <- liftIO Loader.uninitializedLoader
return (Just (Interp (ExternalInterp conf (IServ s)) loader))
else
#if defined(HAVE_INTERNAL_INTERPRETER)
do
loader <- liftIO Loader.uninitializedLoader
return (Just (Interp InternalInterp loader))
#else
return Nothing
#endif
modifySession $ \h -> hscSetFlags dflags
h{ 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
setProgramDynFlags_ :: GhcMonad m => Bool -> DynFlags -> m Bool
setProgramDynFlags_ invalidate_needed dflags = do
logger <- getLogger
dflags0 <- checkNewDynFlags logger dflags
dflags_prev <- getProgramDynFlags
let changed = packageFlagsChanged dflags_prev dflags0
if changed
then do
old_unit_env <- ue_setFlags dflags0 . hsc_unit_env <$> getSession
home_unit_graph <- forM (ue_home_unit_graph old_unit_env) $ \homeUnitEnv -> do
let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv
dflags = homeUnitEnv_dflags homeUnitEnv
old_hpt = homeUnitEnv_hpt homeUnitEnv
home_units = unitEnv_keys (ue_home_unit_graph old_unit_env)
(dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags cached_unit_dbs home_units
updated_dflags <- liftIO $ updatePlatformConstants dflags0 mconstants
pure HomeUnitEnv
{ homeUnitEnv_units = unit_state
, homeUnitEnv_unit_dbs = Just dbs
, homeUnitEnv_dflags = updated_dflags
, homeUnitEnv_hpt = old_hpt
, homeUnitEnv_home_unit = Just home_unit
}
let dflags1 = homeUnitEnv_dflags $ unitEnv_lookup (ue_currentUnit old_unit_env) home_unit_graph
let unit_env = UnitEnv
{ ue_platform = targetPlatform dflags1
, ue_namever = ghcNameVersion dflags1
, ue_home_unit_graph = home_unit_graph
, ue_current_unit = ue_currentUnit old_unit_env
, ue_eps = ue_eps old_unit_env
}
modifySession $ \h -> hscSetFlags dflags1 h{ hsc_unit_env = unit_env }
else modifySession (hscSetFlags dflags0)
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_hash = fingerprint0 }
getProgramDynFlags :: GhcMonad m => m DynFlags
getProgramDynFlags = getSessionDynFlags
setInteractiveDynFlags :: GhcMonad m => DynFlags -> m ()
setInteractiveDynFlags dflags = do
logger <- getLogger
dflags' <- checkNewDynFlags logger dflags
dflags'' <- checkNewInteractiveDynFlags logger dflags'
modifySessionM $ \hsc_env0 -> do
let ic0 = hsc_IC hsc_env0
plugin_env <- liftIO $ initializePlugins $ mkInteractiveHscEnv $
hsc_env0 { hsc_IC = ic0 { ic_dflags = dflags'' }}
return $ hsc_env0
{ hsc_IC = ic0
{ ic_plugins = hsc_plugins plugin_env
, ic_dflags = hsc_dflags plugin_env
}
}
getInteractiveDynFlags :: GhcMonad m => m DynFlags
getInteractiveDynFlags = withSession $ \h -> return (ic_dflags (hsc_IC h))
parseDynamicFlags
:: MonadIO m
=> Logger
-> DynFlags
-> [Located String]
-> m (DynFlags, [Located String], [Warn])
parseDynamicFlags logger dflags cmdline = do
(dflags1, leftovers, warns) <- parseDynamicFlagsCmdLine dflags cmdline
let logger1 = setLogFlags logger (initLogFlags dflags1)
dflags2 <- liftIO $ interpretPackageEnv logger1 dflags1
return (dflags2, leftovers, warns)
parseTargetFiles :: DynFlags -> [String] -> (DynFlags, [(String, Maybe Phase)], [String])
parseTargetFiles dflags0 fileish_args =
let
normal_fileish_paths = map normalise_hyp fileish_args
(srcs, raw_objs) = partition_args normal_fileish_paths [] []
objs = map (augmentByWorkingDirectory dflags0) raw_objs
dflags1 = dflags0 { ldInputs = map (FileOption "") objs
++ ldInputs dflags0 }
in (dflags1, srcs, objs)
partition_args :: [String] -> [(String, Maybe Phase)] -> [String]
-> ([(String, Maybe Phase)], [String])
partition_args [] srcs objs = (reverse srcs, reverse objs)
partition_args ("-x":suff:args) srcs objs
| "none" <- suff = partition_args args srcs objs
| StopLn <- phase = partition_args args srcs (slurp ++ objs)
| otherwise = partition_args rest (these_srcs ++ srcs) objs
where phase = startPhase suff
(slurp,rest) = break (== "-x") args
these_srcs = zip slurp (repeat (Just phase))
partition_args (arg:args) srcs objs
| looks_like_an_input arg = partition_args args ((arg,Nothing):srcs) objs
| otherwise = partition_args args srcs (arg:objs)
looks_like_an_input :: String -> Bool
looks_like_an_input m = isSourceFilename m
|| looksLikeModuleName m
|| "-" `isPrefixOf` m
|| not (hasExtension m)
normalise_hyp :: FilePath -> FilePath
normalise_hyp fp
| strt_dot_sl && "-" `isPrefixOf` nfp = cur_dir ++ nfp
| otherwise = nfp
where
#if defined(mingw32_HOST_OS)
strt_dot_sl = "./" `isPrefixOf` fp || ".\\" `isPrefixOf` fp
#else
strt_dot_sl = "./" `isPrefixOf` fp
#endif
cur_dir = '.' : [pathSeparator]
nfp = normalise fp
checkNewDynFlags :: MonadIO m => Logger -> DynFlags -> m DynFlags
checkNewDynFlags logger dflags = do
let (dflags', warnings) = makeDynFlagsConsistent dflags
let diag_opts = initDiagOpts dflags
liftIO $ handleFlagWarnings logger diag_opts (map (Warn WarningWithoutFlag) warnings)
return dflags'
checkNewInteractiveDynFlags :: MonadIO m => Logger -> DynFlags -> m DynFlags
checkNewInteractiveDynFlags logger dflags0 = do
if xopt LangExt.StaticPointers dflags0
then do
let diag_opts = initDiagOpts dflags0
liftIO $ printOrThrowDiagnostics logger diag_opts $ singleMessage
$ fmap GhcDriverMessage
$ mkPlainMsgEnvelope diag_opts interactiveSrcSpan DriverStaticPointersNotSupported
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 { targetId = id } <- targets, id /= target_id ]
guessTarget :: GhcMonad m => String -> Maybe UnitId -> Maybe Phase -> m Target
guessTarget str mUnitId (Just phase)
= do
tuid <- unitIdOrHomeUnit mUnitId
return (Target (TargetFile str (Just phase)) True tuid Nothing)
guessTarget str mUnitId Nothing
| isHaskellSrcFilename file
= target (TargetFile file Nothing)
| otherwise
= do exists <- liftIO $ doesFileExist hs_file
if exists
then target (TargetFile hs_file Nothing)
else do
exists <- liftIO $ doesFileExist lhs_file
if exists
then target (TargetFile lhs_file Nothing)
else do
if looksLikeModuleName file
then 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 = do
tuid <- unitIdOrHomeUnit mUnitId
pure $ Target tid obj_allowed tuid Nothing
unitIdOrHomeUnit :: GhcMonad m => Maybe UnitId -> m UnitId
unitIdOrHomeUnit mUnitId = do
currentHomeUnitId <- homeUnitId . hsc_home_unit <$> getSession
pure (fromMaybe currentHomeUnitId mUnitId)
workingDirectoryChanged :: GhcMonad m => m ()
workingDirectoryChanged = do
hsc_env <- getSession
liftIO $ flushFinderCaches (hsc_FC hsc_env) (hsc_unit_env hsc_env)
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
type RenamedSource = (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [(LIE GhcRn, Avails)],
Maybe (LHsDoc GhcRn))
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
liftIO $ do
let lcl_hsc_env = hscSetFlags (ms_hspp_opts ms) hsc_env
hpm <- hscParse lcl_hsc_env ms
return (ParsedModule ms (hpm_module hpm) (hpm_src_files hpm))
typecheckModule :: GhcMonad m => ParsedModule -> m TypecheckedModule
typecheckModule pmod = do
hsc_env <- getSession
liftIO $ do
let ms = modSummary pmod
let lcl_dflags = ms_hspp_opts ms
let lcl_hsc_env = hscSetFlags lcl_dflags hsc_env
let lcl_logger = hsc_logger lcl_hsc_env
(tc_gbl_env, rn_info) <- hscTypecheckRename lcl_hsc_env ms $
HsParsedModule { hpm_module = parsedSource pmod,
hpm_src_files = pm_extra_src_files pmod }
details <- makeSimpleDetails lcl_logger tc_gbl_env
safe <- finalSafeMode lcl_dflags 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 $ instEnvElts $ md_insts details,
minf_iface = Nothing,
minf_safe = safe,
minf_modBreaks = emptyModBreaks
}}
desugarModule :: GhcMonad m => TypecheckedModule -> m DesugaredModule
desugarModule tcm = do
hsc_env <- getSession
liftIO $ do
let ms = modSummary tcm
let (tcg, _) = tm_internals tcm
let lcl_hsc_env = hscSetFlags (ms_hspp_opts ms) hsc_env
guts <- hscDesugar lcl_hsc_env ms tcg
return $
DesugaredModule {
dm_typechecked_module = tcm,
dm_core_module = guts
}
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 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 $ hscTidy 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_patsyns 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)
isLoadedModule :: GhcMonad m => UnitId -> ModuleName -> m Bool
isLoadedModule uid m = withSession $ \hsc_env ->
return $! isJust (lookupHug (hsc_HUG hsc_env) uid 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 ->
let (inst_env, fam_env) = ic_instances (hsc_IC hsc_env)
in return (instEnvElts inst_env, fam_env)
getPrintUnqual :: GhcMonad m => m PrintUnqualified
getPrintUnqual = withSession $ \hsc_env -> do
return $ icPrintUnqual (hsc_unit_env 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
if moduleUnitId mdl `S.member` hsc_all_home_unit_ids hsc_env
then liftIO $ getHomeModuleInfo hsc_env mdl
else 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
}))
availsToGlobalRdrEnv :: ModuleName -> [AvailInfo] -> GlobalRdrEnv
availsToGlobalRdrEnv mod_name avails
= mkGlobalRdrEnv (gresFromAvails (Just imp_spec) avails)
where
imp_spec = ImpSpec { is_decl = decl, is_item = ImpAll}
decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name,
is_qual = False,
is_dloc = srcLocSpan interactiveSrcLoc }
getHomeModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
getHomeModuleInfo hsc_env mdl =
case lookupHugByModule mdl (hsc_HUG hsc_env) 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 = instEnvElts $ 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 greMangledName . 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
let mk_print_unqual = mkPrintUnqualified (hsc_unit_env hsc_env)
return (fmap mk_print_unqual (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 -> liftIO (lookupType hsc_env 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 $ lookupType 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 $ icReaderEnv (hsc_IC hsc_env)
getNameToInstancesIndex :: GhcMonad m
=> [Module]
-> Maybe [Module]
-> m (Messages TcRnMessage, 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 :: ModSummary -> IO (String, StringBuffer, DynFlags)
getModuleSourceAndFlags m = do
case ml_hs_file $ ms_location m of
Nothing -> throwIO $ mkApiErr (ms_hspp_opts m) (text "No source available for module " <+> ppr (ms_mod m))
Just sourceFile -> do
source <- hGetStringBuffer sourceFile
return (sourceFile, source, ms_hspp_opts m)
getTokenStream :: ModSummary -> IO [Located Token]
getTokenStream mod = do
(sourceFile, source, dflags) <- getModuleSourceAndFlags mod
let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1
case lexTokenStream (initParserOpts dflags) source startLoc of
POk _ ts -> return ts
PFailed pst -> throwErrors (GhcPsMessage <$> getPsErrorMessages pst)
getRichTokenStream :: ModSummary -> IO [(Located Token, String)]
getRichTokenStream mod = do
(sourceFile, source, dflags) <- getModuleSourceAndFlags mod
let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1
case lexTokenStream (initParserOpts dflags) source startLoc of
POk _ ts -> return $ addSourceToTokens startLoc source ts
PFailed pst -> throwErrors (GhcPsMessage <$> getPsErrorMessages pst)
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 = do
pkg_qual <- renamePkgQualM mod_name maybe_pkg
findQualifiedModule pkg_qual mod_name
findQualifiedModule :: GhcMonad m => PkgQual -> ModuleName -> m Module
findQualifiedModule pkgqual mod_name = withSession $ \hsc_env -> do
let mhome_unit = hsc_home_unit_maybe hsc_env
let dflags = hsc_dflags hsc_env
case pkgqual of
ThisPkg uid -> do
home <- lookupLoadedHomeModule uid mod_name
case home of
Just m -> return m
Nothing -> liftIO $ do
res <- findImportedModule hsc_env mod_name pkgqual
case res of
Found loc m | notHomeModuleMaybe mhome_unit m -> return m
| otherwise -> modNotLoadedError dflags m loc
err -> throwOneError $ noModError hsc_env noSrcSpan mod_name err
_ -> liftIO $ do
res <- findImportedModule hsc_env mod_name pkgqual
case res of
Found _ m -> return m
err -> throwOneError $ noModError hsc_env 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)))
renamePkgQualM :: GhcMonad m => ModuleName -> Maybe FastString -> m PkgQual
renamePkgQualM mn p = withSession $ \hsc_env -> pure (renamePkgQual (hsc_unit_env hsc_env) mn p)
renameRawPkgQualM :: GhcMonad m => ModuleName -> RawPkgQual -> m PkgQual
renameRawPkgQualM mn p = withSession $ \hsc_env -> pure (renameRawPkgQual (hsc_unit_env hsc_env) mn p)
lookupModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module
lookupModule mod_name maybe_pkg = do
pkgqual <- renamePkgQualM mod_name maybe_pkg
lookupQualifiedModule pkgqual mod_name
lookupQualifiedModule :: GhcMonad m => PkgQual -> ModuleName -> m Module
lookupQualifiedModule NoPkgQual mod_name = withSession $ \hsc_env -> do
home <- lookupLoadedHomeModule (homeUnitId $ hsc_home_unit hsc_env) mod_name
case home of
Just m -> return m
Nothing -> liftIO $ do
let fc = hsc_FC hsc_env
let units = hsc_units hsc_env
let dflags = hsc_dflags hsc_env
let fopts = initFinderOpts dflags
res <- findExposedPackageModule fc fopts units mod_name NoPkgQual
case res of
Found _ m -> return m
err -> throwOneError $ noModError hsc_env noSrcSpan mod_name err
lookupQualifiedModule pkgqual mod_name = findQualifiedModule pkgqual mod_name
lookupLoadedHomeModule :: GhcMonad m => UnitId -> ModuleName -> m (Maybe Module)
lookupLoadedHomeModule uid mod_name = withSession $ \hsc_env ->
case lookupHug (hsc_HUG hsc_env) uid 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 (initParserState (initParserOpts dflags) buf loc) of
PFailed pst ->
let (warns,errs) = getPsMessages pst in
(GhcPsMessage <$> warns, Left $ GhcPsMessage <$> errs)
POk pst rdr_module ->
let (warns,_) = getPsMessages pst in
(GhcPsMessage <$> warns, Right rdr_module)
interpretPackageEnv :: Logger -> DynFlags -> IO DynFlags
interpretPackageEnv logger 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 logger (text "Loaded package environment from " <> text envfile)
let (_, dflags') = runCmdLineP (runEwM (setFlagsFromEnvFile envfile content)) dflags
return dflags'
where
archOS = platformArchOS (targetPlatform dflags)
namedEnvPath :: String -> MaybeT IO FilePath
namedEnvPath name = do
appdir <- versionedAppDir (programName dflags) archOS
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 archOS
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"
newtype GhcApiError = GhcApiError String
instance Show GhcApiError where
show (GhcApiError msg) = msg
instance Exception GhcApiError
mkApiErr :: DynFlags -> SDoc -> GhcApiError
mkApiErr dflags msg = GhcApiError (showSDoc dflags msg)
foreign import ccall unsafe "keepCAFsForGHCi"
c_keepCAFsForGHCi :: IO Bool