module HscMain
(
newHscEnv
, Messager, batchMsg
, HscStatus (..)
, hscIncrementalCompile
, hscMaybeWriteIface
, hscCompileCmmFile
, hscGenHardCode
, hscInteractive
, hscParse
, hscTypecheckRename
, hscDesugar
, makeSimpleDetails
, hscSimplify
, hscCheckSafe
, hscGetSafe
, hscParseIdentifier
, hscTcRcLookupName
, hscTcRnGetInfo
, hscIsGHCiMonad
, hscGetModuleInterface
, hscRnImportDecls
, hscTcRnLookupRdrName
, hscStmt, hscParseStmtWithLocation, hscStmtWithLocation, hscParsedStmt
, hscDecls, hscParseDeclsWithLocation, hscDeclsWithLocation, hscParsedDecls
, hscTcExpr, TcRnExprMode(..), hscImport, hscKcType
, hscParseExpr
, hscParseType
, hscCompileCoreExpr
, hscCompileCoreExpr'
, hscParse', hscSimplify', hscDesugar', tcRnModule'
, getHscEnv
, hscSimpleIface'
, oneShotMsg
, hscFileFrontEnd, genericHscFrontend, dumpIfaceStats
, ioMsgMaybe
, showModuleIndex
, hscAddSptEntries
) where
import GhcPrelude
import Data.Data hiding (Fixity, TyCon)
import Data.Maybe ( fromJust )
import Id
import GHCi ( addSptEntry )
import GHCi.RemoteTypes ( ForeignHValue )
import ByteCodeGen ( byteCodeGen, coreExprToBCOs )
import Linker
import CoreTidy ( tidyExpr )
import Type ( Type )
import Type ( Kind )
import CoreLint ( lintInteractiveExpr )
import VarEnv ( emptyTidyEnv )
import Panic
import ConLike
import Control.Concurrent
import Module
import Packages
import RdrName
import GHC.Hs
import GHC.Hs.Dump
import CoreSyn
import StringBuffer
import Parser
import Lexer
import SrcLoc
import TcRnDriver
import TcIface ( typecheckIface )
import TcRnMonad
import TcHsSyn ( ZonkFlexi (DefaultFlexi) )
import NameCache ( initNameCache )
import LoadIface ( ifaceStats, initExternalPackageState )
import PrelInfo
import MkIface
import Desugar
import SimplCore
import TidyPgm
import CorePrep
import CoreToStg ( coreToStg )
import qualified GHC.StgToCmm as StgToCmm ( codeGen )
import StgSyn
import StgFVs ( annTopBindingsFreeVars )
import CostCentre
import ProfInit
import TyCon
import Name
import SimplStg ( stg2stg )
import Cmm
import CmmParse ( parseCmmFile )
import CmmBuildInfoTables
import CmmPipeline
import CmmInfo
import CodeOutput
import InstEnv
import FamInstEnv
import Fingerprint ( Fingerprint )
import Hooks
import TcEnv
import PrelNames
import Plugins
import DynamicLoading ( initializePlugins )
import DynFlags
import ErrUtils
import Outputable
import NameEnv
import HscStats ( ppSourceStats )
import HscTypes
import FastString
import UniqSupply
import Bag
import Exception
import qualified Stream
import Stream (Stream)
import Util
import Data.List ( nub, isPrefixOf, partition )
import Control.Monad
import Data.IORef
import System.FilePath as FilePath
import System.Directory
import System.IO (fixIO)
import qualified Data.Map as M
import qualified Data.Set as S
import Data.Set (Set)
import Control.DeepSeq (force)
import HieAst ( mkHieFile )
import HieTypes ( getAsts, hie_asts, hie_module )
import HieBin ( readHieFile, writeHieFile , hie_file_result)
import HieDebug ( diffFile, validateScopes )
#include "HsVersions.h"
newHscEnv :: DynFlags -> IO HscEnv
newHscEnv dflags = do
eps_var <- newIORef initExternalPackageState
us <- mkSplitUniqSupply 'r'
nc_var <- newIORef (initNameCache us knownKeyNames)
fc_var <- newIORef emptyInstalledModuleEnv
iserv_mvar <- newMVar Nothing
emptyDynLinker <- uninitializedLinker
return HscEnv { hsc_dflags = dflags
, hsc_targets = []
, hsc_mod_graph = emptyMG
, hsc_IC = emptyInteractiveContext dflags
, hsc_HPT = emptyHomePackageTable
, hsc_EPS = eps_var
, hsc_NC = nc_var
, hsc_FC = fc_var
, hsc_type_env_var = Nothing
, hsc_iserv = iserv_mvar
, hsc_dynLinker = emptyDynLinker
}
getWarnings :: Hsc WarningMessages
getWarnings = Hsc $ \_ w -> return (w, w)
clearWarnings :: Hsc ()
clearWarnings = Hsc $ \_ _ -> return ((), emptyBag)
logWarnings :: WarningMessages -> Hsc ()
logWarnings w = Hsc $ \_ w0 -> return ((), w0 `unionBags` w)
getHscEnv :: Hsc HscEnv
getHscEnv = Hsc $ \e w -> return (e, w)
handleWarnings :: Hsc ()
handleWarnings = do
dflags <- getDynFlags
w <- getWarnings
liftIO $ printOrThrowWarnings dflags w
clearWarnings
logWarningsReportErrors :: Messages -> Hsc ()
logWarningsReportErrors (warns,errs) = do
logWarnings warns
when (not $ isEmptyBag errs) $ throwErrors errs
handleWarningsThrowErrors :: Messages -> Hsc a
handleWarningsThrowErrors (warns, errs) = do
logWarnings warns
dflags <- getDynFlags
(wWarns, wErrs) <- warningsToMessages dflags <$> getWarnings
liftIO $ printBagOfErrors dflags wWarns
throwErrors (unionBags errs wErrs)
ioMsgMaybe :: IO (Messages, Maybe a) -> Hsc a
ioMsgMaybe ioA = do
((warns,errs), mb_r) <- liftIO ioA
logWarnings warns
case mb_r of
Nothing -> throwErrors errs
Just r -> ASSERT( isEmptyBag errs ) return r
ioMsgMaybe' :: IO (Messages, Maybe a) -> Hsc (Maybe a)
ioMsgMaybe' ioA = do
((warns,_errs), mb_r) <- liftIO $ ioA
logWarnings warns
return mb_r
hscTcRnLookupRdrName :: HscEnv -> Located RdrName -> IO [Name]
hscTcRnLookupRdrName hsc_env0 rdr_name
= runInteractiveHsc hsc_env0 $
do { hsc_env <- getHscEnv
; ioMsgMaybe $ tcRnLookupRdrName hsc_env rdr_name }
hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing)
hscTcRcLookupName hsc_env0 name = runInteractiveHsc hsc_env0 $ do
hsc_env <- getHscEnv
ioMsgMaybe' $ tcRnLookupName hsc_env name
hscTcRnGetInfo :: HscEnv -> Name
-> IO (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
hscTcRnGetInfo hsc_env0 name
= runInteractiveHsc hsc_env0 $
do { hsc_env <- getHscEnv
; ioMsgMaybe' $ tcRnGetInfo hsc_env name }
hscIsGHCiMonad :: HscEnv -> String -> IO Name
hscIsGHCiMonad hsc_env name
= runHsc hsc_env $ ioMsgMaybe $ isGHCiMonad hsc_env name
hscGetModuleInterface :: HscEnv -> Module -> IO ModIface
hscGetModuleInterface hsc_env0 mod = runInteractiveHsc hsc_env0 $ do
hsc_env <- getHscEnv
ioMsgMaybe $ getModuleInterface hsc_env mod
hscRnImportDecls :: HscEnv -> [LImportDecl GhcPs] -> IO GlobalRdrEnv
hscRnImportDecls hsc_env0 import_decls = runInteractiveHsc hsc_env0 $ do
hsc_env <- getHscEnv
ioMsgMaybe $ tcRnImportDecls hsc_env import_decls
hscParse :: HscEnv -> ModSummary -> IO HsParsedModule
hscParse hsc_env mod_summary = runHsc hsc_env $ hscParse' mod_summary
hscParse' :: ModSummary -> Hsc HsParsedModule
hscParse' mod_summary
| Just r <- ms_parsed_mod mod_summary = return r
| otherwise =
withTimingD (text "Parser"<+>brackets (ppr $ ms_mod mod_summary))
(const ()) $ do
dflags <- getDynFlags
let src_filename = ms_hspp_file mod_summary
maybe_src_buf = ms_hspp_buf mod_summary
buf <- case maybe_src_buf of
Just b -> return b
Nothing -> liftIO $ hGetStringBuffer src_filename
let loc = mkRealSrcLoc (mkFastString src_filename) 1 1
let parseMod | HsigFile == ms_hsc_src mod_summary
= parseSignature
| otherwise = parseModule
case unP parseMod (mkPState dflags buf loc) of
PFailed pst ->
handleWarningsThrowErrors (getMessages pst dflags)
POk pst rdr_module -> do
let (warns, errs) = getMessages pst dflags
logWarnings warns
liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" $
ppr rdr_module
liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed_ast "Parser AST" $
showAstData NoBlankSrcSpan rdr_module
liftIO $ dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics" $
ppSourceStats False rdr_module
when (not $ isEmptyBag errs) $ throwErrors errs
let n_hspp = FilePath.normalise src_filename
srcs0 = nub $ filter (not . (tmpDir dflags `isPrefixOf`))
$ filter (not . (== n_hspp))
$ map FilePath.normalise
$ filter (not . isPrefixOf "<")
$ map unpackFS
$ srcfiles pst
srcs1 = case ml_hs_file (ms_location mod_summary) of
Just f -> filter (/= FilePath.normalise f) srcs0
Nothing -> srcs0
srcs2 <- liftIO $ filterM doesFileExist srcs1
let res = HsParsedModule {
hpm_module = rdr_module,
hpm_src_files = srcs2,
hpm_annotations
= (M.fromListWith (++) $ annotations pst,
M.fromList $ ((noSrcSpan,comment_q pst)
:(annotations_comments pst)))
}
let applyPluginAction p opts
= parsedResultAction p opts mod_summary
withPlugins dflags applyPluginAction res
extract_renamed_stuff :: ModSummary -> TcGblEnv -> Hsc RenamedStuff
extract_renamed_stuff mod_summary tc_result = do
let rn_info = getRenamedStuff tc_result
dflags <- getDynFlags
liftIO $ dumpIfSet_dyn dflags Opt_D_dump_rn_ast "Renamer" $
showAstData NoBlankSrcSpan rn_info
when (gopt Opt_WriteHie dflags) $ do
hieFile <- mkHieFile mod_summary tc_result (fromJust rn_info)
let out_file = ml_hie_file $ ms_location mod_summary
liftIO $ writeHieFile out_file hieFile
when (gopt Opt_ValidateHie dflags) $ do
hs_env <- Hsc $ \e w -> return (e, w)
liftIO $ do
let mdl = hie_module hieFile
case validateScopes mdl $ getAsts $ hie_asts hieFile of
[] -> putMsg dflags $ text "Got valid scopes"
xs -> do
putMsg dflags $ text "Got invalid scopes"
mapM_ (putMsg dflags) xs
nc <- readIORef $ hsc_NC hs_env
(file', _) <- readHieFile nc out_file
case diffFile hieFile (hie_file_result file') of
[] ->
putMsg dflags $ text "Got no roundtrip errors"
xs -> do
putMsg dflags $ text "Got roundtrip errors"
mapM_ (putMsg dflags) xs
return rn_info
hscTypecheckRename :: HscEnv -> ModSummary -> HsParsedModule
-> IO (TcGblEnv, RenamedStuff)
hscTypecheckRename hsc_env mod_summary rdr_module = runHsc hsc_env $ do
tc_result <- hsc_typecheck True mod_summary (Just rdr_module)
rn_info <- extract_renamed_stuff mod_summary tc_result
return (tc_result, rn_info)
hscTypecheck :: Bool
-> ModSummary -> Maybe HsParsedModule
-> Hsc TcGblEnv
hscTypecheck keep_rn mod_summary mb_rdr_module = do
tc_result <- hsc_typecheck keep_rn mod_summary mb_rdr_module
_ <- extract_renamed_stuff mod_summary tc_result
return tc_result
hsc_typecheck :: Bool
-> ModSummary -> Maybe HsParsedModule
-> Hsc TcGblEnv
hsc_typecheck keep_rn mod_summary mb_rdr_module = do
hsc_env <- getHscEnv
let hsc_src = ms_hsc_src mod_summary
dflags = hsc_dflags hsc_env
outer_mod = ms_mod mod_summary
mod_name = moduleName outer_mod
outer_mod' = mkModule (thisPackage dflags) mod_name
inner_mod = canonicalizeHomeModule dflags mod_name
src_filename = ms_hspp_file mod_summary
real_loc = realSrcLocSpan $ mkRealSrcLoc (mkFastString src_filename) 1 1
keep_rn' = gopt Opt_WriteHie dflags || keep_rn
MASSERT( moduleUnitId outer_mod == thisPackage dflags )
if hsc_src == HsigFile && not (isHoleModule inner_mod)
then ioMsgMaybe $ tcRnInstantiateSignature hsc_env outer_mod' real_loc
else
do hpm <- case mb_rdr_module of
Just hpm -> return hpm
Nothing -> hscParse' mod_summary
tc_result0 <- tcRnModule' mod_summary keep_rn' hpm
if hsc_src == HsigFile
then do (iface, _, _) <- liftIO $ hscSimpleIface hsc_env tc_result0 Nothing
ioMsgMaybe $
tcRnMergeSignatures hsc_env hpm tc_result0 iface
else return tc_result0
tcRnModule' :: ModSummary -> Bool -> HsParsedModule
-> Hsc TcGblEnv
tcRnModule' sum save_rn_syntax mod = do
hsc_env <- getHscEnv
dflags <- getDynFlags
when (not (safeHaskellModeEnabled dflags)
&& wopt Opt_WarnMissingSafeHaskellMode dflags) $
logWarnings $ unitBag $
makeIntoWarning (Reason Opt_WarnMissingSafeHaskellMode) $
mkPlainWarnMsg dflags (getLoc (hpm_module mod)) $
warnMissingSafeHaskellMode
tcg_res <-
ioMsgMaybe $
tcRnModule hsc_env sum
save_rn_syntax mod
(tcSafeOK, whyUnsafe) <- liftIO $ readIORef (tcg_safeInfer tcg_res)
let allSafeOK = safeInferred dflags && tcSafeOK
res <- if not (safeHaskellOn dflags)
|| (safeInferOn dflags && not allSafeOK)
then markUnsafeInfer tcg_res whyUnsafe
else do
tcg_res' <- hscCheckSafeImports tcg_res
safe <- liftIO $ fst <$> readIORef (tcg_safeInfer tcg_res')
when safe $ do
case wopt Opt_WarnSafe dflags of
True
| safeHaskell dflags == Sf_Safe -> return ()
| otherwise -> (logWarnings $ unitBag $
makeIntoWarning (Reason Opt_WarnSafe) $
mkPlainWarnMsg dflags (warnSafeOnLoc dflags) $
errSafe tcg_res')
False | safeHaskell dflags == Sf_Trustworthy &&
wopt Opt_WarnTrustworthySafe dflags ->
(logWarnings $ unitBag $
makeIntoWarning (Reason Opt_WarnTrustworthySafe) $
mkPlainWarnMsg dflags (trustworthyOnLoc dflags) $
errTwthySafe tcg_res')
False -> return ()
return tcg_res'
return res
where
pprMod t = ppr $ moduleName $ tcg_mod t
errSafe t = quotes (pprMod t) <+> text "has been inferred as safe!"
errTwthySafe t = quotes (pprMod t)
<+> text "is marked as Trustworthy but has been inferred as safe!"
warnMissingSafeHaskellMode = ppr (moduleName (ms_mod sum))
<+> text "is missing Safe Haskell mode"
hscDesugar :: HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts
hscDesugar hsc_env mod_summary tc_result =
runHsc hsc_env $ hscDesugar' (ms_location mod_summary) tc_result
hscDesugar' :: ModLocation -> TcGblEnv -> Hsc ModGuts
hscDesugar' mod_location tc_result = do
hsc_env <- getHscEnv
r <- ioMsgMaybe $
deSugar hsc_env mod_location tc_result
handleWarnings
return r
makeSimpleDetails :: HscEnv -> TcGblEnv -> IO ModDetails
makeSimpleDetails hsc_env tc_result = mkBootModDetailsTc hsc_env tc_result
type Messager = HscEnv -> (Int,Int) -> RecompileRequired -> ModSummary -> IO ()
hscIncrementalFrontend :: Bool
-> Maybe TcGblEnv
-> Maybe Messager
-> ModSummary
-> SourceModified
-> Maybe ModIface
-> (Int,Int)
-> Hsc (Either ModIface (FrontendResult, Maybe Fingerprint))
hscIncrementalFrontend
always_do_basic_recompilation_check m_tc_result
mHscMessage mod_summary source_modified mb_old_iface mod_index
= do
hsc_env <- getHscEnv
let msg what = case mHscMessage of
Just hscMessage -> hscMessage hsc_env mod_index what mod_summary
Nothing -> return ()
skip iface = do
liftIO $ msg UpToDate
return $ Left iface
compile mb_old_hash reason = do
liftIO $ msg reason
result <- genericHscFrontend mod_summary
return $ Right (result, mb_old_hash)
stable = case source_modified of
SourceUnmodifiedAndStable -> True
_ -> False
case m_tc_result of
Just tc_result
| not always_do_basic_recompilation_check ->
return $ Right (FrontendTypecheck tc_result, Nothing)
_ -> do
(recomp_reqd, mb_checked_iface)
<-
liftIO $ checkOldIface hsc_env mod_summary
source_modified mb_old_iface
let mb_old_hash = fmap (mi_iface_hash . mi_final_exts) mb_checked_iface
case mb_checked_iface of
Just iface | not (recompileRequired recomp_reqd) ->
case m_tc_result of
Nothing
| mi_used_th iface && not stable ->
compile mb_old_hash (RecompBecause "TH")
_ ->
skip iface
_ ->
case m_tc_result of
Nothing -> compile mb_old_hash recomp_reqd
Just tc_result ->
return $ Right (FrontendTypecheck tc_result, mb_old_hash)
genericHscFrontend :: ModSummary -> Hsc FrontendResult
genericHscFrontend mod_summary =
getHooked hscFrontendHook genericHscFrontend' >>= ($ mod_summary)
genericHscFrontend' :: ModSummary -> Hsc FrontendResult
genericHscFrontend' mod_summary
= FrontendTypecheck `fmap` hscFileFrontEnd mod_summary
hscIncrementalCompile :: Bool
-> Maybe TcGblEnv
-> Maybe Messager
-> HscEnv
-> ModSummary
-> SourceModified
-> Maybe ModIface
-> (Int,Int)
-> IO (HscStatus, ModDetails, DynFlags)
hscIncrementalCompile always_do_basic_recompilation_check m_tc_result
mHscMessage hsc_env' mod_summary source_modified mb_old_iface mod_index
= do
dflags <- initializePlugins hsc_env' (hsc_dflags hsc_env')
let hsc_env'' = hsc_env' { hsc_dflags = dflags }
type_env_var <- newIORef emptyNameEnv
let mod = ms_mod mod_summary
hsc_env | isOneShot (ghcMode (hsc_dflags hsc_env''))
= hsc_env'' { hsc_type_env_var = Just (mod, type_env_var) }
| otherwise
= hsc_env''
runHsc hsc_env $ do
e <- hscIncrementalFrontend always_do_basic_recompilation_check m_tc_result mHscMessage
mod_summary source_modified mb_old_iface mod_index
case e of
Left iface -> do
details <- liftIO . fixIO $ \details' -> do
let hsc_env' =
hsc_env {
hsc_HPT = addToHpt (hsc_HPT hsc_env)
(ms_mod_name mod_summary) (HomeModInfo iface details' Nothing)
}
details <- genModDetails hsc_env' iface
return details
return (HscUpToDate iface, details, dflags)
Right (FrontendTypecheck tc_result, mb_old_hash) -> do
(status, mb_old_hash) <- finish mod_summary tc_result mb_old_hash
return (status, mb_old_hash, dflags)
finish :: ModSummary
-> TcGblEnv
-> Maybe Fingerprint
-> Hsc (HscStatus, ModDetails)
finish summary tc_result mb_old_hash = do
hsc_env <- getHscEnv
let dflags = hsc_dflags hsc_env
target = hscTarget dflags
hsc_src = ms_hsc_src summary
should_desugar =
ms_mod summary /= gHC_PRIM && hsc_src == HsSrcFile
mk_simple_iface :: Hsc (HscStatus, ModDetails)
mk_simple_iface = do
(iface, mb_old_iface_hash, details) <- liftIO $
hscSimpleIface hsc_env tc_result mb_old_hash
liftIO $ hscMaybeWriteIface dflags iface mb_old_iface_hash (ms_location summary)
let hsc_status =
case (target, hsc_src) of
(HscNothing, _) -> HscNotGeneratingCode iface
(_, HsBootFile) -> HscUpdateBoot iface
(_, HsigFile) -> HscUpdateSig iface
_ -> panic "finish"
return (hsc_status, details)
if should_desugar
then do
desugared_guts0 <- hscDesugar' (ms_location summary) tc_result
if target == HscNothing
then mk_simple_iface
else do
plugins <- liftIO $ readIORef (tcg_th_coreplugins tc_result)
desugared_guts <- hscSimplify' plugins desugared_guts0
(cg_guts, details) <-
liftIO $ tidyProgram hsc_env desugared_guts
let !partial_iface =
force (mkPartialIface hsc_env details desugared_guts)
return ( HscRecomp { hscs_guts = cg_guts,
hscs_mod_location = ms_location summary,
hscs_partial_iface = partial_iface,
hscs_old_iface_hash = mb_old_hash,
hscs_iface_dflags = dflags },
details )
else mk_simple_iface
hscMaybeWriteIface :: DynFlags -> ModIface -> Maybe Fingerprint -> ModLocation -> IO ()
hscMaybeWriteIface dflags iface old_iface location = do
let force_write_interface = gopt Opt_WriteInterface dflags
write_interface = case hscTarget dflags of
HscNothing -> False
HscInterpreted -> False
_ -> True
no_change = old_iface == Just (mi_iface_hash (mi_final_exts iface))
when (write_interface || force_write_interface) $
hscWriteIface dflags iface no_change location
genModDetails :: HscEnv -> ModIface -> IO ModDetails
genModDetails hsc_env old_iface
= do
new_details <-
initIfaceLoad hsc_env (typecheckIface old_iface)
dumpIfaceStats hsc_env
return new_details
oneShotMsg :: HscEnv -> RecompileRequired -> IO ()
oneShotMsg hsc_env recomp =
case recomp of
UpToDate ->
compilationProgressMsg (hsc_dflags hsc_env) $
"compilation IS NOT required"
_ ->
return ()
batchMsg :: Messager
batchMsg hsc_env mod_index recomp mod_summary =
case recomp of
MustCompile -> showMsg "Compiling " ""
UpToDate
| verbosity (hsc_dflags hsc_env) >= 2 -> showMsg "Skipping " ""
| otherwise -> return ()
RecompBecause reason -> showMsg "Compiling " (" [" ++ reason ++ "]")
where
dflags = hsc_dflags hsc_env
showMsg msg reason =
compilationProgressMsg dflags $
(showModuleIndex mod_index ++
msg ++ showModMsg dflags (hscTarget dflags)
(recompileRequired recomp) mod_summary)
++ reason
hscFileFrontEnd :: ModSummary -> Hsc TcGblEnv
hscFileFrontEnd mod_summary = hscTypecheck False mod_summary Nothing
hscCheckSafeImports :: TcGblEnv -> Hsc TcGblEnv
hscCheckSafeImports tcg_env = do
dflags <- getDynFlags
tcg_env' <- checkSafeImports tcg_env
checkRULES dflags tcg_env'
where
checkRULES dflags tcg_env' = do
case safeLanguageOn dflags of
True -> do
logWarnings $ warns dflags (tcg_rules tcg_env')
return tcg_env' { tcg_rules = [] }
False
| safeInferOn dflags && not (null $ tcg_rules tcg_env')
-> markUnsafeInfer tcg_env' $ warns dflags (tcg_rules tcg_env')
| otherwise
-> return tcg_env'
warns dflags rules = listToBag $ map (warnRules dflags) rules
warnRules :: DynFlags -> GenLocated SrcSpan (RuleDecl GhcTc) -> ErrMsg
warnRules dflags (L loc (HsRule { rd_name = n })) =
mkPlainWarnMsg dflags loc $
text "Rule \"" <> ftext (snd $ unLoc n) <> text "\" ignored" $+$
text "User defined rules are disabled under Safe Haskell"
warnRules _ (L _ (XRuleDecl nec)) = noExtCon nec
checkSafeImports :: TcGblEnv -> Hsc TcGblEnv
checkSafeImports tcg_env
= do
dflags <- getDynFlags
imps <- mapM condense imports'
let (safeImps, regImps) = partition (\(_,_,s) -> s) imps
oldErrs <- getWarnings
clearWarnings
safePkgs <- S.fromList <$> mapMaybeM checkSafe safeImps
safeErrs <- getWarnings
clearWarnings
(infErrs, infPkgs) <- case (safeInferOn dflags) of
False -> return (emptyBag, S.empty)
True -> do infPkgs <- S.fromList <$> mapMaybeM checkSafe regImps
infErrs <- getWarnings
clearWarnings
return (infErrs, infPkgs)
logWarnings oldErrs
case (isEmptyBag safeErrs) of
False -> liftIO . throwIO . mkSrcErr $ safeErrs
True -> do
let infPassed = isEmptyBag infErrs
tcg_env' <- case (not infPassed) of
True -> markUnsafeInfer tcg_env infErrs
False -> return tcg_env
when (packageTrustOn dflags) $ checkPkgTrust pkgReqs
let newTrust = pkgTrustReqs dflags safePkgs infPkgs infPassed
return tcg_env' { tcg_imports = impInfo `plusImportAvails` newTrust }
where
impInfo = tcg_imports tcg_env
imports = imp_mods impInfo
imports1 = moduleEnvToList imports
imports' = map (fmap importedByUser) imports1
pkgReqs = imp_trust_pkgs impInfo
condense :: (Module, [ImportedModsVal]) -> Hsc (Module, SrcSpan, IsSafeImport)
condense (_, []) = panic "HscMain.condense: Pattern match failure!"
condense (m, x:xs) = do imv <- foldlM cond' x xs
return (m, imv_span imv, imv_is_safe imv)
cond' :: ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal
cond' v1 v2
| imv_is_safe v1 /= imv_is_safe v2
= do
dflags <- getDynFlags
throwOneError $ mkPlainErrMsg dflags (imv_span v1)
(text "Module" <+> ppr (imv_name v1) <+>
(text $ "is imported both as a safe and unsafe import!"))
| otherwise
= return v1
checkSafe :: (Module, SrcSpan, a) -> Hsc (Maybe InstalledUnitId)
checkSafe (m, l, _) = fst `fmap` hscCheckSafe' m l
pkgTrustReqs :: DynFlags -> Set InstalledUnitId -> Set InstalledUnitId ->
Bool -> ImportAvails
pkgTrustReqs dflags req inf infPassed | safeInferOn dflags
&& not (safeHaskellModeEnabled dflags) && infPassed
= emptyImportAvails {
imp_trust_pkgs = req `S.union` inf
}
pkgTrustReqs dflags _ _ _ | safeHaskell dflags == Sf_Unsafe
= emptyImportAvails
pkgTrustReqs _ req _ _ = emptyImportAvails { imp_trust_pkgs = req }
hscCheckSafe :: HscEnv -> Module -> SrcSpan -> IO Bool
hscCheckSafe hsc_env m l = runHsc hsc_env $ do
dflags <- getDynFlags
pkgs <- snd `fmap` hscCheckSafe' m l
when (packageTrustOn dflags) $ checkPkgTrust pkgs
errs <- getWarnings
return $ isEmptyBag errs
hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, Set InstalledUnitId)
hscGetSafe hsc_env m l = runHsc hsc_env $ do
(self, pkgs) <- hscCheckSafe' m l
good <- isEmptyBag `fmap` getWarnings
clearWarnings
let pkgs' | Just p <- self = S.insert p pkgs
| otherwise = pkgs
return (good, pkgs')
hscCheckSafe' :: Module -> SrcSpan
-> Hsc (Maybe InstalledUnitId, Set InstalledUnitId)
hscCheckSafe' m l = do
dflags <- getDynFlags
(tw, pkgs) <- isModSafe m l
case tw of
False -> return (Nothing, pkgs)
True | isHomePkg dflags m -> return (Nothing, pkgs)
| otherwise -> return (Just $ toInstalledUnitId (moduleUnitId m), pkgs)
where
isModSafe :: Module -> SrcSpan -> Hsc (Bool, Set InstalledUnitId)
isModSafe m l = do
dflags <- getDynFlags
iface <- lookup' m
case iface of
Nothing -> throwOneError $ mkPlainErrMsg dflags l
$ text "Can't load the interface file for" <+> ppr m
<> text ", to check that it can be safely imported"
Just iface' ->
let trust = getSafeMode $ mi_trust iface'
trust_own_pkg = mi_trust_pkg iface'
safeM = trust `elem` [Sf_Safe, Sf_SafeInferred, Sf_Trustworthy]
safeP = packageTrusted dflags trust trust_own_pkg m
pkgRs = S.fromList . map fst $ filter snd $ dep_pkgs $ mi_deps iface'
warns = if wopt Opt_WarnInferredSafeImports dflags
&& safeLanguageOn dflags
&& trust == Sf_SafeInferred
then inferredImportWarn
else emptyBag
errs = case (safeM, safeP) of
(True, True ) -> emptyBag
(True, False) -> pkgTrustErr
(False, _ ) -> modTrustErr
in do
logWarnings warns
logWarnings errs
return (trust == Sf_Trustworthy, pkgRs)
where
inferredImportWarn = unitBag
$ makeIntoWarning (Reason Opt_WarnInferredSafeImports)
$ mkErrMsg dflags l (pkgQual dflags)
$ sep
[ text "Importing Safe-Inferred module "
<> ppr (moduleName m)
<> text " from explicitly Safe module"
]
pkgTrustErr = unitBag $ mkErrMsg dflags l (pkgQual dflags) $
sep [ ppr (moduleName m)
<> text ": Can't be safely imported!"
, text "The package (" <> ppr (moduleUnitId m)
<> text ") the module resides in isn't trusted."
]
modTrustErr = unitBag $ mkErrMsg dflags l (pkgQual dflags) $
sep [ ppr (moduleName m)
<> text ": Can't be safely imported!"
, text "The module itself isn't safe." ]
packageTrusted :: DynFlags -> SafeHaskellMode -> Bool -> Module -> Bool
packageTrusted _ Sf_None _ _ = False
packageTrusted _ Sf_Ignore _ _ = False
packageTrusted _ Sf_Unsafe _ _ = False
packageTrusted dflags _ _ _
| not (packageTrustOn dflags) = True
packageTrusted _ Sf_Safe False _ = True
packageTrusted _ Sf_SafeInferred False _ = True
packageTrusted dflags _ _ m
| isHomePkg dflags m = True
| otherwise = trusted $ getPackageDetails dflags (moduleUnitId m)
lookup' :: Module -> Hsc (Maybe ModIface)
lookup' m = do
hsc_env <- getHscEnv
hsc_eps <- liftIO $ hscEPS hsc_env
let pkgIfaceT = eps_PIT hsc_eps
homePkgT = hsc_HPT hsc_env
iface = lookupIfaceByModule homePkgT pkgIfaceT m
iface' <- case iface of
Just _ -> return iface
Nothing -> snd `fmap` (liftIO $ getModuleInterface hsc_env m)
return iface'
isHomePkg :: DynFlags -> Module -> Bool
isHomePkg dflags m
| thisPackage dflags == moduleUnitId m = True
| otherwise = False
checkPkgTrust :: Set InstalledUnitId -> Hsc ()
checkPkgTrust pkgs = do
dflags <- getDynFlags
let errors = S.foldr go [] pkgs
go pkg acc
| trusted $ getInstalledPackageDetails dflags pkg
= acc
| otherwise
= (:acc) $ mkErrMsg dflags noSrcSpan (pkgQual dflags)
$ text "The package (" <> ppr pkg <> text ") is required" <>
text " to be trusted but it isn't!"
case errors of
[] -> return ()
_ -> (liftIO . throwIO . mkSrcErr . listToBag) errors
markUnsafeInfer :: TcGblEnv -> WarningMessages -> Hsc TcGblEnv
markUnsafeInfer tcg_env whyUnsafe = do
dflags <- getDynFlags
when (wopt Opt_WarnUnsafe dflags)
(logWarnings $ unitBag $ makeIntoWarning (Reason Opt_WarnUnsafe) $
mkPlainWarnMsg dflags (warnUnsafeOnLoc dflags) (whyUnsafe' dflags))
liftIO $ writeIORef (tcg_safeInfer tcg_env) (False, whyUnsafe)
case not (safeHaskellModeEnabled dflags) of
True -> return $ tcg_env { tcg_imports = wiped_trust }
False -> return tcg_env
where
wiped_trust = (tcg_imports tcg_env) { imp_trust_pkgs = S.empty }
pprMod = ppr $ moduleName $ tcg_mod tcg_env
whyUnsafe' df = vcat [ quotes pprMod <+> text "has been inferred as unsafe!"
, text "Reason:"
, nest 4 $ (vcat $ badFlags df) $+$
(vcat $ pprErrMsgBagWithLoc whyUnsafe) $+$
(vcat $ badInsts $ tcg_insts tcg_env)
]
badFlags df = concat $ map (badFlag df) unsafeFlagsForInfer
badFlag df (str,loc,on,_)
| on df = [mkLocMessage SevOutput (loc df) $
text str <+> text "is not allowed in Safe Haskell"]
| otherwise = []
badInsts insts = concat $ map badInst insts
checkOverlap (NoOverlap _) = False
checkOverlap _ = True
badInst ins | checkOverlap (overlapMode (is_flag ins))
= [mkLocMessage SevOutput (nameSrcSpan $ getName $ is_dfun ins) $
ppr (overlapMode $ is_flag ins) <+>
text "overlap mode isn't allowed in Safe Haskell"]
| otherwise = []
hscGetSafeMode :: TcGblEnv -> Hsc SafeHaskellMode
hscGetSafeMode tcg_env = do
dflags <- getDynFlags
liftIO $ finalSafeMode dflags tcg_env
hscSimplify :: HscEnv -> [String] -> ModGuts -> IO ModGuts
hscSimplify hsc_env plugins modguts =
runHsc hsc_env $ hscSimplify' plugins modguts
hscSimplify' :: [String] -> ModGuts -> Hsc ModGuts
hscSimplify' plugins ds_result = do
hsc_env <- getHscEnv
let hsc_env_with_plugins = hsc_env
{ hsc_dflags = foldr addPluginModuleName (hsc_dflags hsc_env) plugins
}
liftIO $ core2core hsc_env_with_plugins ds_result
hscSimpleIface :: HscEnv
-> TcGblEnv
-> Maybe Fingerprint
-> IO (ModIface, Maybe Fingerprint, ModDetails)
hscSimpleIface hsc_env tc_result mb_old_iface
= runHsc hsc_env $ hscSimpleIface' tc_result mb_old_iface
hscSimpleIface' :: TcGblEnv
-> Maybe Fingerprint
-> Hsc (ModIface, Maybe Fingerprint, ModDetails)
hscSimpleIface' tc_result mb_old_iface = do
hsc_env <- getHscEnv
details <- liftIO $ mkBootModDetailsTc hsc_env tc_result
safe_mode <- hscGetSafeMode tc_result
new_iface
<-
liftIO $
mkIfaceTc hsc_env safe_mode details tc_result
liftIO $ dumpIfaceStats hsc_env
return (new_iface, mb_old_iface, details)
hscWriteIface :: DynFlags -> ModIface -> Bool -> ModLocation -> IO ()
hscWriteIface dflags iface no_change mod_location = do
let ifaceBaseFile = ml_hi_file mod_location
unless no_change $
let ifaceFile = buildIfName ifaceBaseFile (hiSuf dflags)
in
writeIfaceFile dflags ifaceFile iface
whenGeneratingDynamicToo dflags $ do
let dynDflags = dynamicTooMkDynamicDynFlags dflags
dynIfaceFile = buildIfName ifaceBaseFile (hiSuf dynDflags)
writeIfaceFile dynDflags dynIfaceFile iface
where
buildIfName :: String -> String -> String
buildIfName baseName suffix
| Just name <- outputHi dflags
= name
| otherwise
= let with_hi = replaceExtension baseName suffix
in addBootSuffix_maybe (mi_boot iface) with_hi
hscGenHardCode :: HscEnv -> CgGuts -> ModLocation -> FilePath
-> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)])
hscGenHardCode hsc_env cgguts location output_filename = do
let CgGuts{
cg_module = this_mod,
cg_binds = core_binds,
cg_tycons = tycons,
cg_foreign = foreign_stubs0,
cg_foreign_files = foreign_files,
cg_dep_pkgs = dependencies,
cg_hpc_info = hpc_info } = cgguts
dflags = hsc_dflags hsc_env
data_tycons = filter isDataTyCon tycons
(prepd_binds, local_ccs) <-
corePrepPgm hsc_env this_mod location
core_binds data_tycons
(stg_binds, (caf_ccs, caf_cc_stacks))
<-
myCoreToStg dflags this_mod prepd_binds
let cost_centre_info =
(S.toList local_ccs ++ caf_ccs, caf_cc_stacks)
prof_init = profilingInitCode this_mod cost_centre_info
foreign_stubs = foreign_stubs0 `appendStubC` prof_init
withTiming dflags
(text "CodeGen"<+>brackets (ppr this_mod))
(const ()) $ do
cmms <-
doCodeGen hsc_env this_mod data_tycons
cost_centre_info
stg_binds hpc_info
rawcmms0 <-
cmmToRawCmm dflags cmms
let dump a = do dumpIfSet_dyn dflags Opt_D_dump_cmm_raw "Raw Cmm"
(ppr a)
return a
rawcmms1 = Stream.mapM dump rawcmms0
(output_filename, (_stub_h_exists, stub_c_exists), foreign_fps, ())
<-
codeOutput dflags this_mod output_filename location
foreign_stubs foreign_files dependencies rawcmms1
return (output_filename, stub_c_exists, foreign_fps)
hscInteractive :: HscEnv
-> CgGuts
-> ModLocation
-> IO (Maybe FilePath, CompiledByteCode, [SptEntry])
hscInteractive hsc_env cgguts location = do
let dflags = hsc_dflags hsc_env
let CgGuts{
cg_module = this_mod,
cg_binds = core_binds,
cg_tycons = tycons,
cg_foreign = foreign_stubs,
cg_modBreaks = mod_breaks,
cg_spt_entries = spt_entries } = cgguts
data_tycons = filter isDataTyCon tycons
(prepd_binds, _) <-
corePrepPgm hsc_env this_mod location core_binds data_tycons
comp_bc <- byteCodeGen hsc_env this_mod prepd_binds data_tycons mod_breaks
(_istub_h_exists, istub_c_exists)
<- outputForeignStubs dflags this_mod location foreign_stubs
return (istub_c_exists, comp_bc, spt_entries)
hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> IO ()
hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do
let dflags = hsc_dflags hsc_env
cmm <- ioMsgMaybe $ parseCmmFile dflags filename
liftIO $ do
dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose_by_proc "Parsed Cmm" (ppr cmm)
let
mod_name = mkModuleName $ "Cmm$" ++ FilePath.takeFileName filename
cmm_mod = mkModule (thisPackage dflags) mod_name
(_, cmmgroup) <- cmmPipeline hsc_env (emptySRT cmm_mod) cmm
dumpIfSet_dyn dflags Opt_D_dump_cmm "Output Cmm" (ppr cmmgroup)
rawCmms <- cmmToRawCmm dflags (Stream.yield cmmgroup)
_ <- codeOutput dflags cmm_mod output_filename no_loc NoStubs [] []
rawCmms
return ()
where
no_loc = ModLocation{ ml_hs_file = Just filename,
ml_hi_file = panic "hscCompileCmmFile: no hi file",
ml_obj_file = panic "hscCompileCmmFile: no obj file",
ml_hie_file = panic "hscCompileCmmFile: no hie file"}
doCodeGen :: HscEnv -> Module -> [TyCon]
-> CollectedCCs
-> [StgTopBinding]
-> HpcInfo
-> IO (Stream IO CmmGroup ())
doCodeGen hsc_env this_mod data_tycons
cost_centre_info stg_binds hpc_info = do
let dflags = hsc_dflags hsc_env
let stg_binds_w_fvs = annTopBindingsFreeVars stg_binds
let cmm_stream :: Stream IO CmmGroup ()
cmm_stream =
StgToCmm.codeGen dflags this_mod data_tycons
cost_centre_info stg_binds_w_fvs hpc_info
let dump1 a = do dumpIfSet_dyn dflags Opt_D_dump_cmm_from_stg
"Cmm produced by codegen" (ppr a)
return a
ppr_stream1 = Stream.mapM dump1 cmm_stream
pipeline_stream
=
let run_pipeline = cmmPipeline hsc_env
in void $ Stream.mapAccumL run_pipeline (emptySRT this_mod) ppr_stream1
dump2 a = do dumpIfSet_dyn dflags Opt_D_dump_cmm
"Output Cmm" (ppr a)
return a
ppr_stream2 = Stream.mapM dump2 pipeline_stream
return ppr_stream2
myCoreToStg :: DynFlags -> Module -> CoreProgram
-> IO ( [StgTopBinding]
, CollectedCCs )
myCoreToStg dflags this_mod prepd_binds = do
let (stg_binds, cost_centre_info)
=
coreToStg dflags this_mod prepd_binds
stg_binds2
<-
stg2stg dflags this_mod stg_binds
return (stg_binds2, cost_centre_info)
hscStmt :: HscEnv -> String -> IO (Maybe ([Id], ForeignHValue, FixityEnv))
hscStmt hsc_env stmt = hscStmtWithLocation hsc_env stmt "<interactive>" 1
hscStmtWithLocation :: HscEnv
-> String
-> String
-> Int
-> IO ( Maybe ([Id]
, ForeignHValue
, FixityEnv))
hscStmtWithLocation hsc_env0 stmt source linenumber =
runInteractiveHsc hsc_env0 $ do
maybe_stmt <- hscParseStmtWithLocation source linenumber stmt
case maybe_stmt of
Nothing -> return Nothing
Just parsed_stmt -> do
hsc_env <- getHscEnv
liftIO $ hscParsedStmt hsc_env parsed_stmt
hscParsedStmt :: HscEnv
-> GhciLStmt GhcPs
-> IO ( Maybe ([Id]
, ForeignHValue
, FixityEnv))
hscParsedStmt hsc_env stmt = runInteractiveHsc hsc_env $ do
(ids, tc_expr, fix_env) <- ioMsgMaybe $ tcRnStmt hsc_env stmt
ds_expr <- ioMsgMaybe $ deSugarExpr hsc_env tc_expr
liftIO (lintInteractiveExpr "desugar expression" hsc_env ds_expr)
handleWarnings
let src_span = srcLocSpan interactiveSrcLoc
hval <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr
return $ Just (ids, hval, fix_env)
hscDecls :: HscEnv
-> String
-> IO ([TyThing], InteractiveContext)
hscDecls hsc_env str = hscDeclsWithLocation hsc_env str "<interactive>" 1
hscParseDeclsWithLocation :: HscEnv -> String -> Int -> String -> IO [LHsDecl GhcPs]
hscParseDeclsWithLocation hsc_env source line_num str = do
L _ (HsModule{ hsmodDecls = decls }) <-
runInteractiveHsc hsc_env $
hscParseThingWithLocation source line_num parseModule str
return decls
hscDeclsWithLocation :: HscEnv
-> String
-> String
-> Int
-> IO ([TyThing], InteractiveContext)
hscDeclsWithLocation hsc_env str source linenumber = do
L _ (HsModule{ hsmodDecls = decls }) <-
runInteractiveHsc hsc_env $
hscParseThingWithLocation source linenumber parseModule str
hscParsedDecls hsc_env decls
hscParsedDecls :: HscEnv -> [LHsDecl GhcPs] -> IO ([TyThing], InteractiveContext)
hscParsedDecls hsc_env decls = runInteractiveHsc hsc_env $ do
hsc_env <- getHscEnv
tc_gblenv <- ioMsgMaybe $ tcRnDeclsi hsc_env decls
let defaults = tcg_default tc_gblenv
let iNTERACTIVELoc = ModLocation{ ml_hs_file = Nothing,
ml_hi_file = panic "hsDeclsWithLocation:ml_hi_file",
ml_obj_file = panic "hsDeclsWithLocation:ml_obj_file",
ml_hie_file = panic "hsDeclsWithLocation:ml_hie_file" }
ds_result <- hscDesugar' iNTERACTIVELoc tc_gblenv
simpl_mg <- liftIO $ do
plugins <- readIORef (tcg_th_coreplugins tc_gblenv)
hscSimplify hsc_env plugins ds_result
(tidy_cg, mod_details) <- liftIO $ tidyProgram hsc_env simpl_mg
let !CgGuts{ cg_module = this_mod,
cg_binds = core_binds,
cg_tycons = tycons,
cg_modBreaks = mod_breaks } = tidy_cg
!ModDetails { md_insts = cls_insts
, md_fam_insts = fam_insts } = mod_details
data_tycons = filter isDataTyCon tycons
(prepd_binds, _) <-
liftIO $ corePrepPgm hsc_env this_mod iNTERACTIVELoc core_binds data_tycons
cbc <- liftIO $ byteCodeGen hsc_env this_mod
prepd_binds data_tycons mod_breaks
let src_span = srcLocSpan interactiveSrcLoc
liftIO $ linkDecls hsc_env src_span cbc
liftIO $ hscAddSptEntries hsc_env (cg_spt_entries tidy_cg)
let tcs = filterOut isImplicitTyCon (mg_tcs simpl_mg)
patsyns = mg_patsyns simpl_mg
ext_ids = [ id | id <- bindersOfBinds core_binds
, isExternalName (idName id)
, not (isDFunId id || isImplicitId id) ]
new_tythings = map AnId ext_ids ++ map ATyCon tcs ++ map (AConLike . PatSynCon) patsyns
ictxt = hsc_IC hsc_env
fix_env = tcg_fix_env tc_gblenv
new_ictxt = extendInteractiveContext ictxt new_tythings cls_insts
fam_insts defaults fix_env
return (new_tythings, new_ictxt)
hscAddSptEntries :: HscEnv -> [SptEntry] -> IO ()
hscAddSptEntries hsc_env entries = do
let add_spt_entry :: SptEntry -> IO ()
add_spt_entry (SptEntry i fpr) = do
val <- getHValue hsc_env (idName i)
addSptEntry hsc_env fpr val
mapM_ add_spt_entry entries
hscImport :: HscEnv -> String -> IO (ImportDecl GhcPs)
hscImport hsc_env str = runInteractiveHsc hsc_env $ do
(L _ (HsModule{hsmodImports=is})) <-
hscParseThing parseModule str
case is of
[L _ i] -> return i
_ -> liftIO $ throwOneError $
mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan $
text "parse error in import declaration"
hscTcExpr :: HscEnv
-> TcRnExprMode
-> String
-> IO Type
hscTcExpr hsc_env0 mode expr = runInteractiveHsc hsc_env0 $ do
hsc_env <- getHscEnv
parsed_expr <- hscParseExpr expr
ioMsgMaybe $ tcRnExpr hsc_env mode parsed_expr
hscKcType
:: HscEnv
-> Bool
-> String
-> IO (Type, Kind)
hscKcType hsc_env0 normalise str = runInteractiveHsc hsc_env0 $ do
hsc_env <- getHscEnv
ty <- hscParseType str
ioMsgMaybe $ tcRnType hsc_env DefaultFlexi normalise ty
hscParseExpr :: String -> Hsc (LHsExpr GhcPs)
hscParseExpr expr = do
hsc_env <- getHscEnv
maybe_stmt <- hscParseStmt expr
case maybe_stmt of
Just (L _ (BodyStmt _ expr _ _)) -> return expr
_ -> throwOneError $ mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan
(text "not an expression:" <+> quotes (text expr))
hscParseStmt :: String -> Hsc (Maybe (GhciLStmt GhcPs))
hscParseStmt = hscParseThing parseStmt
hscParseStmtWithLocation :: String -> Int -> String
-> Hsc (Maybe (GhciLStmt GhcPs))
hscParseStmtWithLocation source linenumber stmt =
hscParseThingWithLocation source linenumber parseStmt stmt
hscParseType :: String -> Hsc (LHsType GhcPs)
hscParseType = hscParseThing parseType
hscParseIdentifier :: HscEnv -> String -> IO (Located RdrName)
hscParseIdentifier hsc_env str =
runInteractiveHsc hsc_env $ hscParseThing parseIdentifier str
hscParseThing :: (Outputable thing, Data thing)
=> Lexer.P thing -> String -> Hsc thing
hscParseThing = hscParseThingWithLocation "<interactive>" 1
hscParseThingWithLocation :: (Outputable thing, Data thing) => String -> Int
-> Lexer.P thing -> String -> Hsc thing
hscParseThingWithLocation source linenumber parser str
= withTimingD
(text "Parser [source]")
(const ()) $ do
dflags <- getDynFlags
let buf = stringToStringBuffer str
loc = mkRealSrcLoc (fsLit source) linenumber 1
case unP parser (mkPState dflags buf loc) of
PFailed pst -> do
handleWarningsThrowErrors (getMessages pst dflags)
POk pst thing -> do
logWarningsReportErrors (getMessages pst dflags)
liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing)
liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed_ast "Parser AST" $
showAstData NoBlankSrcSpan thing
return thing
hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue
hscCompileCoreExpr hsc_env =
lookupHook hscCompileCoreExprHook hscCompileCoreExpr' (hsc_dflags hsc_env) hsc_env
hscCompileCoreExpr' :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue
hscCompileCoreExpr' hsc_env srcspan ds_expr
= do { let dflags = hsc_dflags hsc_env
; simpl_expr <- simplifyExpr dflags ds_expr
; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr
; prepd_expr <- corePrepExpr dflags hsc_env tidy_expr
; lintInteractiveExpr "hscCompileExpr" hsc_env prepd_expr
; bcos <- coreExprToBCOs hsc_env
(icInteractiveModule (hsc_IC hsc_env)) prepd_expr
; hval <- linkExpr hsc_env srcspan bcos
; return hval }
dumpIfaceStats :: HscEnv -> IO ()
dumpIfaceStats hsc_env = do
eps <- readIORef (hsc_EPS hsc_env)
dumpIfSet dflags (dump_if_trace || dump_rn_stats)
"Interface statistics"
(ifaceStats eps)
where
dflags = hsc_dflags hsc_env
dump_rn_stats = dopt Opt_D_dump_rn_stats dflags
dump_if_trace = dopt Opt_D_dump_if_trace dflags
showModuleIndex :: (Int, Int) -> String
showModuleIndex (i,n) = "[" ++ padded ++ " of " ++ n_str ++ "] "
where
n_str = show n
i_str = show i
padded = replicate (length n_str length i_str) ' ' ++ i_str