Commit 5a0b8270 authored by dterei's avatar dterei
Browse files

Fix GHC API with respect to safe haskell. (#5989)

This fixes haddock so it correctly reports
the safe haskell mode of a module.
parent 7ed67597
...@@ -20,6 +20,7 @@ import StaticFlags ...@@ -20,6 +20,7 @@ import StaticFlags
import HscTypes import HscTypes
import HsSyn import HsSyn
import TcRnTypes import TcRnTypes
import TcRnMonad ( finalSafeMode )
import MkIface import MkIface
import Id import Id
import Name import Name
...@@ -169,6 +170,7 @@ deSugar hsc_env ...@@ -169,6 +170,7 @@ deSugar hsc_env
; used_th <- readIORef tc_splice_used ; used_th <- readIORef tc_splice_used
; dep_files <- readIORef dependent_files ; dep_files <- readIORef dependent_files
; safe_mode <- finalSafeMode dflags tcg_env
; let mod_guts = ModGuts { ; let mod_guts = ModGuts {
mg_module = mod, mg_module = mod,
...@@ -194,6 +196,7 @@ deSugar hsc_env ...@@ -194,6 +196,7 @@ deSugar hsc_env
mg_modBreaks = modBreaks, mg_modBreaks = modBreaks,
mg_vect_decls = ds_vects, mg_vect_decls = ds_vects,
mg_vect_info = noVectInfo, mg_vect_info = noVectInfo,
mg_safe_haskell = safe_mode,
mg_trust_pkg = imp_trust_own_pkg imports, mg_trust_pkg = imp_trust_own_pkg imports,
mg_dependent_files = dep_files mg_dependent_files = dep_files
} }
......
...@@ -145,22 +145,25 @@ mkIface hsc_env maybe_old_fingerprint mod_details ...@@ -145,22 +145,25 @@ mkIface hsc_env maybe_old_fingerprint mod_details
mg_fix_env = fix_env, mg_fix_env = fix_env,
mg_warns = warns, mg_warns = warns,
mg_hpc_info = hpc_info, mg_hpc_info = hpc_info,
mg_safe_haskell = safe_mode,
mg_trust_pkg = self_trust, mg_trust_pkg = self_trust,
mg_dependent_files = dependent_files mg_dependent_files = dependent_files
} }
= mkIface_ hsc_env maybe_old_fingerprint = mkIface_ hsc_env maybe_old_fingerprint
this_mod is_boot used_names used_th deps rdr_env fix_env this_mod is_boot used_names used_th deps rdr_env fix_env
warns hpc_info dir_imp_mods self_trust dependent_files mod_details warns hpc_info dir_imp_mods self_trust dependent_files
safe_mode mod_details
-- | make an interface from the results of typechecking only. Useful -- | make an interface from the results of typechecking only. Useful
-- for non-optimising compilation, or where we aren't generating any -- for non-optimising compilation, or where we aren't generating any
-- object code at all ('HscNothing'). -- object code at all ('HscNothing').
mkIfaceTc :: HscEnv mkIfaceTc :: HscEnv
-> Maybe Fingerprint -- The old fingerprint, if we have it -> Maybe Fingerprint -- The old fingerprint, if we have it
-> SafeHaskellMode -- The safe haskell mode
-> ModDetails -- gotten from mkBootModDetails, probably -> ModDetails -- gotten from mkBootModDetails, probably
-> TcGblEnv -- Usages, deprecations, etc -> TcGblEnv -- Usages, deprecations, etc
-> IO (Messages, Maybe (ModIface, Bool)) -> IO (Messages, Maybe (ModIface, Bool))
mkIfaceTc hsc_env maybe_old_fingerprint mod_details mkIfaceTc hsc_env maybe_old_fingerprint safe_mode mod_details
tc_result@TcGblEnv{ tcg_mod = this_mod, tc_result@TcGblEnv{ tcg_mod = this_mod,
tcg_src = hsc_src, tcg_src = hsc_src,
tcg_imports = imports, tcg_imports = imports,
...@@ -180,7 +183,7 @@ mkIfaceTc hsc_env maybe_old_fingerprint mod_details ...@@ -180,7 +183,7 @@ mkIfaceTc hsc_env maybe_old_fingerprint mod_details
mkIface_ hsc_env maybe_old_fingerprint mkIface_ hsc_env maybe_old_fingerprint
this_mod (isHsBoot hsc_src) used_names used_th deps rdr_env this_mod (isHsBoot hsc_src) used_names used_th deps rdr_env
fix_env warns hpc_info (imp_mods imports) fix_env warns hpc_info (imp_mods imports)
(imp_trust_own_pkg imports) dep_files mod_details (imp_trust_own_pkg imports) dep_files safe_mode mod_details
mkUsedNames :: TcGblEnv -> NameSet mkUsedNames :: TcGblEnv -> NameSet
...@@ -226,11 +229,12 @@ mkIface_ :: HscEnv -> Maybe Fingerprint -> Module -> IsBootInterface ...@@ -226,11 +229,12 @@ mkIface_ :: HscEnv -> Maybe Fingerprint -> Module -> IsBootInterface
-> NameEnv FixItem -> Warnings -> HpcInfo -> NameEnv FixItem -> Warnings -> HpcInfo
-> ImportedMods -> Bool -> ImportedMods -> Bool
-> [FilePath] -> [FilePath]
-> SafeHaskellMode
-> ModDetails -> ModDetails
-> IO (Messages, Maybe (ModIface, Bool)) -> IO (Messages, Maybe (ModIface, Bool))
mkIface_ hsc_env maybe_old_fingerprint mkIface_ hsc_env maybe_old_fingerprint
this_mod is_boot used_names used_th deps rdr_env fix_env src_warns this_mod is_boot used_names used_th deps rdr_env fix_env src_warns
hpc_info dir_imp_mods pkg_trust_req dependent_files hpc_info dir_imp_mods pkg_trust_req dependent_files safe_mode
ModDetails{ md_insts = insts, ModDetails{ md_insts = insts,
md_fam_insts = fam_insts, md_fam_insts = fam_insts,
md_rules = rules, md_rules = rules,
...@@ -244,7 +248,6 @@ mkIface_ hsc_env maybe_old_fingerprint ...@@ -244,7 +248,6 @@ mkIface_ hsc_env maybe_old_fingerprint
-- to expose in the interface -- to expose in the interface
= do { usages <- mkUsageInfo hsc_env this_mod dir_imp_mods used_names dependent_files = do { usages <- mkUsageInfo hsc_env this_mod dir_imp_mods used_names dependent_files
; safeInf <- hscGetSafeInf hsc_env
; let { entities = typeEnvElts type_env ; ; let { entities = typeEnvElts type_env ;
decls = [ tyThingToIfaceDecl entity decls = [ tyThingToIfaceDecl entity
...@@ -263,13 +266,7 @@ mkIface_ hsc_env maybe_old_fingerprint ...@@ -263,13 +266,7 @@ mkIface_ hsc_env maybe_old_fingerprint
; iface_insts = map instanceToIfaceInst insts ; iface_insts = map instanceToIfaceInst insts
; iface_fam_insts = map famInstToIfaceFamInst fam_insts ; iface_fam_insts = map famInstToIfaceFamInst fam_insts
; iface_vect_info = flattenVectInfo vect_info ; iface_vect_info = flattenVectInfo vect_info
; trust_info = setSafeMode safe_mode
-- Check if we are in Safe Inference mode
-- but we failed to pass the muster
; safeMode = if safeInferOn dflags && not safeInf
then Sf_None
else safeHaskell dflags
; trust_info = setSafeMode safeMode
; intermediate_iface = ModIface { ; intermediate_iface = ModIface {
mi_module = this_mod, mi_module = this_mod,
......
...@@ -72,10 +72,12 @@ module GHC ( ...@@ -72,10 +72,12 @@ module GHC (
modInfoIsExportedName, modInfoIsExportedName,
modInfoLookupName, modInfoLookupName,
modInfoIface, modInfoIface,
modInfoSafe,
lookupGlobalName, lookupGlobalName,
findGlobalAnns, findGlobalAnns,
mkPrintUnqualifiedForModule, mkPrintUnqualifiedForModule,
ModIface(..), ModIface(..),
SafeHaskellMode(..),
-- * Querying the environment -- * Querying the environment
packageDbModules, packageDbModules,
...@@ -254,6 +256,7 @@ import HscMain ...@@ -254,6 +256,7 @@ import HscMain
import GhcMake import GhcMake
import DriverPipeline ( compile' ) import DriverPipeline ( compile' )
import GhcMonad import GhcMonad
import TcRnMonad ( finalSafeMode )
import TcRnTypes import TcRnTypes
import Packages import Packages
import NameSet import NameSet
...@@ -737,6 +740,7 @@ typecheckModule pmod = do ...@@ -737,6 +740,7 @@ typecheckModule pmod = do
HsParsedModule { hpm_module = parsedSource pmod, HsParsedModule { hpm_module = parsedSource pmod,
hpm_src_files = pm_extra_src_files pmod } hpm_src_files = pm_extra_src_files pmod }
details <- liftIO $ makeSimpleDetails hsc_env_tmp tc_gbl_env details <- liftIO $ makeSimpleDetails hsc_env_tmp tc_gbl_env
safe <- liftIO $ finalSafeMode (ms_hspp_opts ms) tc_gbl_env
return $ return $
TypecheckedModule { TypecheckedModule {
tm_internals_ = (tc_gbl_env, details), tm_internals_ = (tc_gbl_env, details),
...@@ -749,7 +753,8 @@ typecheckModule pmod = do ...@@ -749,7 +753,8 @@ typecheckModule pmod = do
minf_exports = availsToNameSet $ md_exports details, minf_exports = availsToNameSet $ md_exports details,
minf_rdr_env = Just (tcg_rdr_env tc_gbl_env), minf_rdr_env = Just (tcg_rdr_env tc_gbl_env),
minf_instances = md_insts details, minf_instances = md_insts details,
minf_iface = Nothing minf_iface = Nothing,
minf_safe = safe
#ifdef GHCI #ifdef GHCI
,minf_modBreaks = emptyModBreaks ,minf_modBreaks = emptyModBreaks
#endif #endif
...@@ -823,12 +828,16 @@ data CoreModule ...@@ -823,12 +828,16 @@ data CoreModule
-- | Type environment for types declared in this module -- | Type environment for types declared in this module
cm_types :: !TypeEnv, cm_types :: !TypeEnv,
-- | Declarations -- | Declarations
cm_binds :: CoreProgram cm_binds :: CoreProgram,
-- | Safe Haskell mode
cm_safe :: SafeHaskellMode
} }
instance Outputable CoreModule where instance Outputable CoreModule where
ppr (CoreModule {cm_module = mn, cm_types = te, cm_binds = cb}) = ppr (CoreModule {cm_module = mn, cm_types = te, cm_binds = cb,
text "%module" <+> ppr mn <+> ppr te $$ vcat (map ppr cb) cm_safe = sf})
= text "%module" <+> ppr mn <+> parens (ppr sf) <+> ppr te
$$ vcat (map ppr cb)
-- | This is the way to get access to the Core bindings corresponding -- | This is the way to get access to the Core bindings corresponding
-- to a module. 'compileToCore' parses, typechecks, and -- to a module. 'compileToCore' parses, typechecks, and
...@@ -865,7 +874,7 @@ compileCoreToObj simplify cm@(CoreModule{ cm_module = mName }) = do ...@@ -865,7 +874,7 @@ compileCoreToObj simplify cm@(CoreModule{ cm_module = mName }) = do
modLocation <- liftIO $ mkHiOnlyModLocation dflags (hiSuf dflags) cwd modLocation <- liftIO $ mkHiOnlyModLocation dflags (hiSuf dflags) cwd
((moduleNameSlashes . moduleName) mName) ((moduleNameSlashes . moduleName) mName)
let modSummary = ModSummary { ms_mod = mName, let modSum = ModSummary { ms_mod = mName,
ms_hsc_src = ExtCoreFile, ms_hsc_src = ExtCoreFile,
ms_location = modLocation, ms_location = modLocation,
-- By setting the object file timestamp to Nothing, -- By setting the object file timestamp to Nothing,
...@@ -884,7 +893,7 @@ compileCoreToObj simplify cm@(CoreModule{ cm_module = mName }) = do ...@@ -884,7 +893,7 @@ compileCoreToObj simplify cm@(CoreModule{ cm_module = mName }) = do
} }
hsc_env <- getSession hsc_env <- getSession
liftIO $ hscCompileCore hsc_env simplify modSummary (cm_binds cm) liftIO $ hscCompileCore hsc_env simplify (cm_safe cm) modSum (cm_binds cm)
compileCore :: GhcMonad m => Bool -> FilePath -> m CoreModule compileCore :: GhcMonad m => Bool -> FilePath -> m CoreModule
...@@ -902,7 +911,7 @@ compileCore simplify fn = do ...@@ -902,7 +911,7 @@ compileCore simplify fn = do
mod_guts <- coreModule `fmap` mod_guts <- coreModule `fmap`
-- TODO: space leaky: call hsc* directly? -- TODO: space leaky: call hsc* directly?
(desugarModule =<< typecheckModule =<< parseModule modSummary) (desugarModule =<< typecheckModule =<< parseModule modSummary)
liftM gutsToCoreModule $ liftM (gutsToCoreModule (mg_safe_haskell mod_guts)) $
if simplify if simplify
then do then do
-- If simplify is true: simplify (hscSimplify), then tidy -- If simplify is true: simplify (hscSimplify), then tidy
...@@ -919,18 +928,22 @@ compileCore simplify fn = do ...@@ -919,18 +928,22 @@ compileCore simplify fn = do
where -- two versions, based on whether we simplify (thus run tidyProgram, where -- two versions, based on whether we simplify (thus run tidyProgram,
-- which returns a (CgGuts, ModDetails) pair, or not (in which case -- which returns a (CgGuts, ModDetails) pair, or not (in which case
-- we just have a ModGuts. -- we just have a ModGuts.
gutsToCoreModule :: Either (CgGuts, ModDetails) ModGuts -> CoreModule gutsToCoreModule :: SafeHaskellMode
gutsToCoreModule (Left (cg, md)) = CoreModule { -> Either (CgGuts, ModDetails) ModGuts
-> CoreModule
gutsToCoreModule safe_mode (Left (cg, md)) = CoreModule {
cm_module = cg_module cg, cm_module = cg_module cg,
cm_types = md_types md, cm_types = md_types md,
cm_binds = cg_binds cg cm_binds = cg_binds cg,
cm_safe = safe_mode
} }
gutsToCoreModule (Right mg) = CoreModule { gutsToCoreModule safe_mode (Right mg) = CoreModule {
cm_module = mg_module mg, cm_module = mg_module mg,
cm_types = typeEnvFromEntities (bindersOfBinds (mg_binds mg)) cm_types = typeEnvFromEntities (bindersOfBinds (mg_binds mg))
(mg_tcs mg) (mg_tcs mg)
(mg_fam_insts mg), (mg_fam_insts mg),
cm_binds = mg_binds mg cm_binds = mg_binds mg,
cm_safe = safe_mode
} }
-- %************************************************************************ -- %************************************************************************
...@@ -977,7 +990,8 @@ data ModuleInfo = ModuleInfo { ...@@ -977,7 +990,8 @@ data ModuleInfo = ModuleInfo {
minf_exports :: NameSet, -- ToDo, [AvailInfo] like ModDetails? minf_exports :: NameSet, -- ToDo, [AvailInfo] like ModDetails?
minf_rdr_env :: Maybe GlobalRdrEnv, -- Nothing for a compiled/package mod minf_rdr_env :: Maybe GlobalRdrEnv, -- Nothing for a compiled/package mod
minf_instances :: [ClsInst], minf_instances :: [ClsInst],
minf_iface :: Maybe ModIface minf_iface :: Maybe ModIface,
minf_safe :: SafeHaskellMode
#ifdef GHCI #ifdef GHCI
,minf_modBreaks :: ModBreaks ,minf_modBreaks :: ModBreaks
#endif #endif
...@@ -1020,6 +1034,7 @@ getPackageModuleInfo hsc_env mdl ...@@ -1020,6 +1034,7 @@ getPackageModuleInfo hsc_env mdl
minf_rdr_env = Just $! availsToGlobalRdrEnv (moduleName mdl) avails, minf_rdr_env = Just $! availsToGlobalRdrEnv (moduleName mdl) avails,
minf_instances = error "getModuleInfo: instances for package module unimplemented", minf_instances = error "getModuleInfo: instances for package module unimplemented",
minf_iface = Just iface, minf_iface = Just iface,
minf_safe = getSafeMode $ mi_trust iface,
minf_modBreaks = emptyModBreaks minf_modBreaks = emptyModBreaks
})) }))
#else #else
...@@ -1040,7 +1055,8 @@ getHomeModuleInfo hsc_env mdl = ...@@ -1040,7 +1055,8 @@ getHomeModuleInfo hsc_env mdl =
minf_exports = availsToNameSet (md_exports details), minf_exports = availsToNameSet (md_exports details),
minf_rdr_env = mi_globals $! hm_iface hmi, minf_rdr_env = mi_globals $! hm_iface hmi,
minf_instances = md_insts details, minf_instances = md_insts details,
minf_iface = Just iface minf_iface = Just iface,
minf_safe = getSafeMode $ mi_trust iface
#ifdef GHCI #ifdef GHCI
,minf_modBreaks = getModBreaks hmi ,minf_modBreaks = getModBreaks hmi
#endif #endif
...@@ -1085,6 +1101,10 @@ modInfoLookupName minf name = withSession $ \hsc_env -> do ...@@ -1085,6 +1101,10 @@ modInfoLookupName minf name = withSession $ \hsc_env -> do
modInfoIface :: ModuleInfo -> Maybe ModIface modInfoIface :: ModuleInfo -> Maybe ModIface
modInfoIface = minf_iface modInfoIface = minf_iface
-- | Retrieve module safe haskell mode
modInfoSafe :: ModuleInfo -> SafeHaskellMode
modInfoSafe = minf_safe
#ifdef GHCI #ifdef GHCI
modInfoModBreaks :: ModuleInfo -> ModBreaks modInfoModBreaks :: ModuleInfo -> ModBreaks
modInfoModBreaks = minf_modBreaks modInfoModBreaks = minf_modBreaks
......
...@@ -171,7 +171,6 @@ newHscEnv dflags = do ...@@ -171,7 +171,6 @@ newHscEnv dflags = do
fc_var <- newIORef emptyUFM fc_var <- newIORef emptyUFM
mlc_var <- newIORef emptyModuleEnv mlc_var <- newIORef emptyModuleEnv
optFuel <- initOptFuelState optFuel <- initOptFuelState
safe_var <- newIORef True
return HscEnv { hsc_dflags = dflags, return HscEnv { hsc_dflags = dflags,
hsc_targets = [], hsc_targets = [],
hsc_mod_graph = [], hsc_mod_graph = [],
...@@ -182,8 +181,7 @@ newHscEnv dflags = do ...@@ -182,8 +181,7 @@ newHscEnv dflags = do
hsc_FC = fc_var, hsc_FC = fc_var,
hsc_MLC = mlc_var, hsc_MLC = mlc_var,
hsc_OptFuel = optFuel, hsc_OptFuel = optFuel,
hsc_type_env_var = Nothing, hsc_type_env_var = Nothing }
hsc_safeInf = safe_var }
knownKeyNames :: [Name] -- Put here to avoid loops involving DsMeta, knownKeyNames :: [Name] -- Put here to avoid loops involving DsMeta,
...@@ -405,10 +403,7 @@ type RenamedStuff = ...@@ -405,10 +403,7 @@ type RenamedStuff =
hscTypecheckRename :: HscEnv -> ModSummary -> HsParsedModule hscTypecheckRename :: HscEnv -> ModSummary -> HsParsedModule
-> IO (TcGblEnv, RenamedStuff) -> IO (TcGblEnv, RenamedStuff)
hscTypecheckRename hsc_env mod_summary rdr_module = runHsc hsc_env $ do hscTypecheckRename hsc_env mod_summary rdr_module = runHsc hsc_env $ do
tc_result <- {-# SCC "Typecheck-Rename" #-} tc_result <- tcRnModule' hsc_env mod_summary True rdr_module
ioMsgMaybe $
tcRnModule hsc_env (ms_hsc_src mod_summary)
True rdr_module
-- This 'do' is in the Maybe monad! -- This 'do' is in the Maybe monad!
let rn_info = do decl <- tcg_rn_decls tc_result let rn_info = do decl <- tcg_rn_decls tc_result
...@@ -419,6 +414,34 @@ hscTypecheckRename hsc_env mod_summary rdr_module = runHsc hsc_env $ do ...@@ -419,6 +414,34 @@ hscTypecheckRename hsc_env mod_summary rdr_module = runHsc hsc_env $ do
return (tc_result, rn_info) return (tc_result, rn_info)
-- wrapper around tcRnModule to handle safe haskell extras
tcRnModule' :: HscEnv -> ModSummary -> Bool -> HsParsedModule
-> Hsc TcGblEnv
tcRnModule' hsc_env sum save_rn_syntax mod = do
tcg_res <- {-# SCC "Typecheck-Rename" #-}
ioMsgMaybe $
tcRnModule hsc_env (ms_hsc_src sum) save_rn_syntax mod
tcSafeOK <- liftIO $ readIORef (tcg_safeInfer tcg_res)
dflags <- getDynFlags
-- end of the Safe Haskell line, how to respond to user?
if not (safeHaskellOn dflags) || (safeInferOn dflags && not tcSafeOK)
-- if safe haskell off or safe infer failed, wipe trust
then wipeTrust tcg_res emptyBag
-- module safe, throw warning if needed
else do
tcg_res' <- hscCheckSafeImports tcg_res
safe <- liftIO $ readIORef (tcg_safeInfer tcg_res')
when (safe && wopt Opt_WarnSafe dflags)
(logWarnings $ unitBag $
mkPlainWarnMsg (warnSafeOnLoc dflags) $ errSafe tcg_res')
return tcg_res'
where
pprMod t = ppr $ moduleName $ tcg_mod t
errSafe t = quotes (pprMod t) <+> text "has been infered as safe!"
-- | Convert a typechecked module to Core -- | Convert a typechecked module to Core
hscDesugar :: HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts hscDesugar :: HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts
hscDesugar hsc_env mod_summary tc_result = hscDesugar hsc_env mod_summary tc_result =
...@@ -443,9 +466,11 @@ hscDesugar' mod_location tc_result = do ...@@ -443,9 +466,11 @@ hscDesugar' mod_location tc_result = do
-- we should use fingerprint versions instead. -- we should use fingerprint versions instead.
makeSimpleIface :: HscEnv -> Maybe ModIface -> TcGblEnv -> ModDetails makeSimpleIface :: HscEnv -> Maybe ModIface -> TcGblEnv -> ModDetails
-> IO (ModIface,Bool) -> IO (ModIface,Bool)
makeSimpleIface hsc_env maybe_old_iface tc_result details = makeSimpleIface hsc_env maybe_old_iface tc_result details = runHsc hsc_env $ do
runHsc hsc_env $ ioMsgMaybe $ safe_mode <- hscGetSafeMode tc_result
mkIfaceTc hsc_env (fmap mi_iface_hash maybe_old_iface) details tc_result ioMsgMaybe $ do
mkIfaceTc hsc_env (fmap mi_iface_hash maybe_old_iface) safe_mode
details tc_result
-- | Make a 'ModDetails' from the results of typechecking. Used when -- | Make a 'ModDetails' from the results of typechecking. Used when
-- typechecking only, as opposed to full compilation. -- typechecking only, as opposed to full compilation.
...@@ -836,30 +861,8 @@ hscFileFrontEnd :: ModSummary -> Hsc TcGblEnv ...@@ -836,30 +861,8 @@ hscFileFrontEnd :: ModSummary -> Hsc TcGblEnv
hscFileFrontEnd mod_summary = do hscFileFrontEnd mod_summary = do
hpm <- hscParse' mod_summary hpm <- hscParse' mod_summary
hsc_env <- getHscEnv hsc_env <- getHscEnv
dflags <- getDynFlags tcg_env <- tcRnModule' hsc_env mod_summary False hpm
tcg_env <- return tcg_env
{-# SCC "Typecheck-Rename" #-}
ioMsgMaybe $
tcRnModule hsc_env (ms_hsc_src mod_summary) False hpm
tcSafeOK <- liftIO $ readIORef (tcg_safeInfer tcg_env)
-- end of the Safe Haskell line, how to respond to user?
if not (safeHaskellOn dflags) || (safeInferOn dflags && not tcSafeOK)
-- if safe haskell off or safe infer failed, wipe trust
then wipeTrust tcg_env emptyBag
-- module safe, throw warning if needed
else do
tcg_env' <- hscCheckSafeImports tcg_env
safe <- liftIO $ hscGetSafeInf hsc_env
when (safe && wopt Opt_WarnSafe dflags)
(logWarnings $ unitBag $
mkPlainWarnMsg (warnSafeOnLoc dflags) $ errSafe tcg_env')
return tcg_env'
where
pprMod t = ppr $ moduleName $ tcg_mod t
errSafe t = quotes (pprMod t) <+> text "has been infered as safe!"
-------------------------------------------------------------- --------------------------------------------------------------
-- Safe Haskell -- Safe Haskell
...@@ -1124,14 +1127,13 @@ checkPkgTrust dflags pkgs = ...@@ -1124,14 +1127,13 @@ checkPkgTrust dflags pkgs =
-- it should be a central and single failure method. -- it should be a central and single failure method.
wipeTrust :: TcGblEnv -> WarningMessages -> Hsc TcGblEnv wipeTrust :: TcGblEnv -> WarningMessages -> Hsc TcGblEnv
wipeTrust tcg_env whyUnsafe = do wipeTrust tcg_env whyUnsafe = do
env <- getHscEnv
dflags <- getDynFlags dflags <- getDynFlags
when (wopt Opt_WarnUnsafe dflags) when (wopt Opt_WarnUnsafe dflags)
(logWarnings $ unitBag $ (logWarnings $ unitBag $
mkPlainWarnMsg (warnUnsafeOnLoc dflags) (whyUnsafe' dflags)) mkPlainWarnMsg (warnUnsafeOnLoc dflags) (whyUnsafe' dflags))
liftIO $ hscSetSafeInf env False liftIO $ writeIORef (tcg_safeInfer tcg_env) False
return $ tcg_env { tcg_imports = wiped_trust } return $ tcg_env { tcg_imports = wiped_trust }
where where
...@@ -1148,6 +1150,12 @@ wipeTrust tcg_env whyUnsafe = do ...@@ -1148,6 +1150,12 @@ wipeTrust tcg_env whyUnsafe = do
text str <+> text "is not allowed in Safe Haskell"] text str <+> text "is not allowed in Safe Haskell"]
| otherwise = [] | otherwise = []
-- | Figure out the final correct safe haskell mode
hscGetSafeMode :: TcGblEnv -> Hsc SafeHaskellMode
hscGetSafeMode tcg_env = do
dflags <- getDynFlags
liftIO $ finalSafeMode dflags tcg_env
-------------------------------------------------------------- --------------------------------------------------------------
-- Simplifiers -- Simplifiers
-------------------------------------------------------------- --------------------------------------------------------------
...@@ -1171,10 +1179,11 @@ hscSimpleIface :: TcGblEnv ...@@ -1171,10 +1179,11 @@ hscSimpleIface :: TcGblEnv
hscSimpleIface tc_result mb_old_iface = do hscSimpleIface tc_result mb_old_iface = do
hsc_env <- getHscEnv hsc_env <- getHscEnv
details <- liftIO $ mkBootModDetailsTc hsc_env tc_result details <- liftIO $ mkBootModDetailsTc hsc_env tc_result
safe_mode <- hscGetSafeMode tc_result
(new_iface, no_change) (new_iface, no_change)
<- {-# SCC "MkFinalIface" #-} <- {-# SCC "MkFinalIface" #-}
ioMsgMaybe $ ioMsgMaybe $
mkIfaceTc hsc_env mb_old_iface details tc_result mkIfaceTc hsc_env mb_old_iface safe_mode details tc_result
-- And the answer is ... -- And the answer is ...
liftIO $ dumpIfaceStats hsc_env liftIO $ dumpIfaceStats hsc_env
return (new_iface, no_change, details) return (new_iface, no_change, details)
...@@ -1588,9 +1597,11 @@ hscParseThingWithLocation source linenumber parser str ...@@ -1588,9 +1597,11 @@ hscParseThingWithLocation source linenumber parser str
liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing) liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing)
return thing return thing
hscCompileCore :: HscEnv -> Bool -> ModSummary -> CoreProgram -> IO () hscCompileCore :: HscEnv -> Bool -> SafeHaskellMode -> ModSummary
hscCompileCore hsc_env simplify mod_summary binds = runHsc hsc_env $ do -> CoreProgram -> IO ()
guts <- maybe_simplify (mkModGuts (ms_mod mod_summary) binds) hscCompileCore hsc_env simplify safe_mode mod_summary binds
= runHsc hsc_env $ do
guts <- maybe_simplify (mkModGuts (ms_mod mod_summary) safe_mode binds)
(iface, changed, _details, cgguts) <- hscNormalIface guts Nothing (iface, changed, _details, cgguts) <- hscNormalIface guts Nothing
hscWriteIface iface changed mod_summary hscWriteIface iface changed mod_summary
_ <- hscGenHardCode cgguts mod_summary _ <- hscGenHardCode cgguts mod_summary
...@@ -1601,8 +1612,8 @@ hscCompileCore hsc_env simplify mod_summary binds = runHsc hsc_env $ do ...@@ -1601,8 +1612,8 @@ hscCompileCore hsc_env simplify mod_summary binds = runHsc hsc_env $ do
| otherwise = return mod_guts | otherwise = return mod_guts
-- Makes a "vanilla" ModGuts. -- Makes a "vanilla" ModGuts.
mkModGuts :: Module -> CoreProgram -> ModGuts mkModGuts :: Module -> SafeHaskellMode -> CoreProgram -> ModGuts
mkModGuts mod binds = mkModGuts mod safe binds =
ModGuts { ModGuts {
mg_module = mod, mg_module = mod,
mg_boot = False, mg_boot = False,
...@@ -1627,6 +1638,7 @@ mkModGuts mod binds = ...@@ -1627,6 +1638,7 @@ mkModGuts mod binds =
mg_vect_info = noVectInfo, mg_vect_info = noVectInfo,
mg_inst_env = emptyInstEnv, mg_inst_env = emptyInstEnv,
mg_fam_inst_env = emptyFamInstEnv, mg_fam_inst_env = emptyFamInstEnv,
mg_safe_haskell = safe,
mg_trust_pkg = False, mg_trust_pkg = False,
mg_dependent_files = [] mg_dependent_files = []
} }
......
...@@ -95,7 +95,6 @@ module HscTypes ( ...@@ -95,7 +95,6 @@ module HscTypes (
noIfaceVectInfo, isNoIfaceVectInfo, noIfaceVectInfo, isNoIfaceVectInfo,
-- * Safe Haskell information -- * Safe Haskell information
hscGetSafeInf, hscSetSafeInf,
IfaceTrustInfo, getSafeMode, setSafeMode, noIfaceTrustInfo,