Commit 14bbddac authored by dterei's avatar dterei

Add Safe Haskell '-fwarn-safe', '-fwarn-unsafe', '-fno-safe-infer' flags

parent 78ee2937
......@@ -262,7 +262,7 @@ mkIface_ hsc_env maybe_old_fingerprint
; iface_vect_info = flattenVectInfo vect_info
-- Check if we are in Safe Inference mode but we failed to pass
-- the muster
; safeMode = if safeInferOn dflags && not safeInf
; safeMode = if safeInferOn dflags && not safeInf
then Sf_None
else safeHaskell dflags
; trust_info = setSafeMode safeMode
......
......@@ -338,6 +338,8 @@ data WarningFlag =
| Opt_WarnUnusedDoBind
| Opt_WarnWrongDoBind
| Opt_WarnAlternativeLayoutRuleTransitional
| Opt_WarnUnsafe
| Opt_WarnSafe
deriving (Eq, Show)
data Language = Haskell98 | Haskell2010
......@@ -560,6 +562,8 @@ data DynFlags = DynFlags {
-- them off.
thOnLoc :: SrcSpan,
newDerivOnLoc :: SrcSpan,
warnSafeOnLoc :: SrcSpan,
warnUnsafeOnLoc :: SrcSpan,
-- Don't change this without updating extensionFlags:
extensions :: [OnOff ExtensionFlag],
-- extensionFlags should always be equal to
......@@ -894,6 +898,8 @@ defaultDynFlags mySettings =
safeHaskell = Sf_SafeInfered,
thOnLoc = noSrcSpan,
newDerivOnLoc = noSrcSpan,
warnSafeOnLoc = noSrcSpan,
warnUnsafeOnLoc = noSrcSpan,
extensions = [],
extensionFlags = flattenExtensionFlags Nothing [],
log_action = defaultLogAction,
......@@ -1076,10 +1082,12 @@ safeImplicitImpsReq d = safeLanguageOn d
-- want to export this functionality from the module but do want to export the
-- type constructors.
combineSafeFlags :: SafeHaskellMode -> SafeHaskellMode -> DynP SafeHaskellMode
combineSafeFlags a b | a `elem` [Sf_None, Sf_SafeInfered] = return b
| b `elem` [Sf_None, Sf_SafeInfered] = return a
| a == b = return a
| otherwise = addErr errm >> return (panic errm)
combineSafeFlags a b | a == Sf_SafeInfered = return b
| b == Sf_SafeInfered = return a
| a == Sf_None = return b
| b == Sf_None = return a
| a == b = return a
| otherwise = addErr errm >> return (panic errm)
where errm = "Incompatible Safe Haskell flags! ("
++ showPpr a ++ ", " ++ showPpr b ++ ")"
......@@ -1638,6 +1646,7 @@ dynamic_flags = [
------ Safe Haskell flags -------------------------------------------
, Flag "fpackage-trust" (NoArg (setDynFlag Opt_PackageTrust))
, Flag "fno-safe-infer" (NoArg (setSafeHaskell Sf_None))
]
++ map (mkFlag turnOn "f" setDynFlag ) fFlags
++ map (mkFlag turnOff "fno-" unSetDynFlag) fFlags
......@@ -1737,10 +1746,12 @@ fWarningFlags = [
( "warn-auto-orphans", Opt_WarnAutoOrphans, nop ),
( "warn-tabs", Opt_WarnTabs, nop ),
( "warn-unrecognised-pragmas", Opt_WarnUnrecognisedPragmas, nop ),
( "warn-lazy-unlifted-bindings", Opt_WarnLazyUnliftedBindings, nop),
( "warn-lazy-unlifted-bindings", Opt_WarnLazyUnliftedBindings, nop ),
( "warn-unused-do-bind", Opt_WarnUnusedDoBind, nop ),
( "warn-wrong-do-bind", Opt_WarnWrongDoBind, nop ),
( "warn-alternative-layout-rule-transitional", Opt_WarnAlternativeLayoutRuleTransitional, nop )]
( "warn-alternative-layout-rule-transitional", Opt_WarnAlternativeLayoutRuleTransitional, nop ),
( "warn-unsafe", Opt_WarnUnsafe, setWarnUnsafe ),
( "warn-safe", Opt_WarnSafe, setWarnSafe ) ]
-- | These @-f\<blah\>@ flags can all be reversed with @-fno-\<blah\>@
fFlags :: [FlagSpec DynFlag]
......@@ -2137,6 +2148,14 @@ rtsIsProfiled :: Bool
rtsIsProfiled = unsafePerformIO rtsIsProfiledIO /= 0
#endif
setWarnSafe :: Bool -> DynP ()
setWarnSafe True = getCurLoc >>= \l -> upd (\d -> d { warnSafeOnLoc = l })
setWarnSafe False = return ()
setWarnUnsafe :: Bool -> DynP ()
setWarnUnsafe True = getCurLoc >>= \l -> upd (\d -> d { warnUnsafeOnLoc = l })
setWarnUnsafe False = return ()
setGenDeriving :: Bool -> DynP ()
setGenDeriving True = getCurLoc >>= \l -> upd (\d -> d { newDerivOnLoc = l })
setGenDeriving False = return ()
......
......@@ -12,7 +12,7 @@
-- for details
module ErrUtils (
Message, mkLocMessage, printError, pprMessageBag,
Message, mkLocMessage, printError, pprMessageBag, pprErrMsgBag,
Severity(..),
ErrMsg, WarnMsg,
......@@ -149,23 +149,31 @@ printBagOfWarnings :: DynFlags -> Bag WarnMsg -> IO ()
printBagOfWarnings dflags bag_of_warns =
printMsgBag dflags bag_of_warns SevWarning
pprErrMsgBag :: Bag ErrMsg -> [SDoc]
pprErrMsgBag bag
= [ let style = mkErrStyle unqual
in withPprStyle style (d $$ e)
| ErrMsg { errMsgShortDoc = d,
errMsgExtraInfo = e,
errMsgContext = unqual } <- sortMsgBag bag ]
printMsgBag :: DynFlags -> Bag ErrMsg -> Severity -> IO ()
printMsgBag dflags bag sev
= sequence_ [ let style = mkErrStyle unqual
in log_action dflags sev s style (d $$ e)
| ErrMsg { errMsgSpans = s:_,
errMsgShortDoc = d,
errMsgExtraInfo = e,
errMsgContext = unqual } <- sorted_errs ]
where
bag_ls = bagToList bag
sorted_errs = sortLe occ'ed_before bag_ls
occ'ed_before err1 err2 =
case compare (head (errMsgSpans err1)) (head (errMsgSpans err2)) of
LT -> True
EQ -> True
GT -> False
= sequence_ [ let style = mkErrStyle unqual
in log_action dflags sev s style (d $$ e)
| ErrMsg { errMsgSpans = s:_,
errMsgShortDoc = d,
errMsgExtraInfo = e,
errMsgContext = unqual } <- sortMsgBag bag ]
sortMsgBag :: Bag ErrMsg -> [ErrMsg]
sortMsgBag bag = sortLe srcOrder $ bagToList bag
where
srcOrder err1 err2 =
case compare (head (errMsgSpans err1)) (head (errMsgSpans err2)) of
LT -> True
EQ -> True
GT -> False
ghcExit :: DynFlags -> Int -> IO ()
ghcExit dflags val
......
......@@ -167,7 +167,7 @@ newHscEnv dflags = do
mlc_var <- newIORef emptyModuleEnv
optFuel <- initOptFuelState
safe_var <- newIORef True
return HscEnv { hsc_dflags = dflags,
return HscEnv { hsc_dflags = dflags,
hsc_targets = [],
hsc_mod_graph = [],
hsc_IC = emptyInteractiveContext,
......@@ -790,10 +790,25 @@ hscFileFrontEnd mod_summary = do
ioMsgMaybe $
tcRnModule hsc_env (ms_hsc_src mod_summary) False rdr_module
tcSafeOK <- liftIO $ readIORef (tcg_safeInfer tcg_env)
-- if safe haskell off or safe infer failed, wipe trust
-- end of the Safe Haskell line, how to respond to user?
if not (safeHaskellOn dflags) || (safeInferOn dflags && not tcSafeOK)
then wipeTrust tcg_env
else hscCheckSafeImports tcg_env
-- 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 = text "Warning:" <+> quotes (pprMod t)
<+> text "has been infered as safe!"
--------------------------------------------------------------
-- Safe Haskell
......@@ -850,9 +865,9 @@ hscCheckSafeImports tcg_env = do
-- user defined RULES, so not safe or already unsafe
| safeInferOn dflags && not (null $ tcg_rules tcg_env') ||
safeHaskell dflags == Sf_None
-> wipeTrust tcg_env'
-> wipeTrust tcg_env' $ warns (tcg_rules tcg_env')
-- trustworthy
-- trustworthy OR safe infered with no RULES
| otherwise
-> return tcg_env'
......@@ -900,7 +915,7 @@ checkSafeImports dflags hsc_env tcg_env
True ->
-- did we fail safe inference or fail -XSafe?
case safeInferOn dflags of
True -> wipeTrust tcg_env
True -> wipeTrust tcg_env errs
False -> liftIO . throwIO . mkSrcErr $ errs
-- All good matey!
......@@ -1025,12 +1040,29 @@ checkSafeImports dflags hsc_env tcg_env
| otherwise = Just (modulePackageId m)
-- | Set module to unsafe and wipe trust information.
wipeTrust :: TcGblEnv -> Hsc TcGblEnv
wipeTrust tcg_env = do
env <- getHscEnv
--
-- Make sure to call this method to set a module to infered unsafe,
-- it should be a central and single failure method.
wipeTrust :: TcGblEnv -> WarningMessages -> Hsc TcGblEnv
wipeTrust tcg_env whyUnsafe = do
env <- getHscEnv
dflags <- getDynFlags
when (wopt Opt_WarnUnsafe dflags)
(logWarnings $ unitBag $
mkPlainWarnMsg (warnUnsafeOnLoc dflags) whyUnsafe')
liftIO $ hscSetSafeInf env False
let imps = (tcg_imports tcg_env) { imp_trust_pkgs = [] }
return $ tcg_env { tcg_imports = imps }
return $ tcg_env { tcg_imports = wiped_trust }
where
wiped_trust = (tcg_imports tcg_env) { imp_trust_pkgs = [] }
pprMod = ppr $ moduleName $ tcg_mod tcg_env
whyUnsafe' = vcat [ text "Warning:" <+> quotes pprMod
<+> text "has been infered as unsafe!"
, text "Reason:"
, nest 4 (vcat $ pprErrMsgBag whyUnsafe) ]
--------------------------------------------------------------
-- Simplifiers
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment