Commit 14bbddac authored by dterei's avatar dterei
Browse files

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

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