Skip to content

GitLab

Commit e69619e9 authored by David Terei's avatar David Terei
8 Browse files
Options

Allow warning if could have been infered safe instead of explicit 

Trustworthy label.
parent 578fbeca
Hide whitespace changes
Inline Side-by-side
Showing with 93 additions and 75 deletions
compiler/main/DynFlags.hs
View file @ e69619e9
......@@ -61,7 +61,7 @@ module DynFlags (
safeHaskellOn, safeImportsOn, safeLanguageOn, safeInferOn,
packageTrustOn,
safeDirectImpsReq, safeImplicitImpsReq,
unsafeFlags,
unsafeFlags, unsafeFlagsForInfer,
-- ** System tool settings and locations
Settings(..),
......@@ -480,7 +480,6 @@ data SafeHaskellMode
| Sf_Unsafe
| Sf_Trustworthy
| Sf_Safe
| Sf_SafeInferred
deriving (Eq)
instance Show SafeHaskellMode where
......@@ -488,7 +487,6 @@ instance Show SafeHaskellMode where
show Sf_Unsafe = "Unsafe"
show Sf_Trustworthy = "Trustworthy"
show Sf_Safe = "Safe"
show Sf_SafeInferred = "Safe-Inferred"
instance Outputable SafeHaskellMode where
ppr = text . show
......@@ -737,11 +735,14 @@ data DynFlags = DynFlags {
language :: Maybe Language,
-- | Safe Haskell mode
safeHaskell :: SafeHaskellMode,
safeInfer :: Bool,
safeInferred :: Bool,
-- We store the location of where some extension and flags were turned on so
-- we can produce accurate error messages when Safe Haskell fails due to
-- them.
thOnLoc :: SrcSpan,
newDerivOnLoc :: SrcSpan,
overlapInstLoc :: SrcSpan,
pkgTrustOnLoc :: SrcSpan,
warnSafeOnLoc :: SrcSpan,
warnUnsafeOnLoc :: SrcSpan,
......@@ -1416,9 +1417,12 @@ defaultDynFlags mySettings =
warningFlags = IntSet.fromList (map fromEnum standardWarnings),
ghciScripts = [],
language = Nothing,
safeHaskell = Sf_SafeInferred,
safeHaskell = Sf_None,
safeInfer = True,
safeInferred = True,
thOnLoc = noSrcSpan,
newDerivOnLoc = noSrcSpan,
overlapInstLoc = noSrcSpan,
pkgTrustOnLoc = noSrcSpan,
warnSafeOnLoc = noSrcSpan,
warnUnsafeOnLoc = noSrcSpan,
......@@ -1701,7 +1705,7 @@ packageTrustOn = gopt Opt_PackageTrust
-- | Is Safe Haskell on in some way (including inference mode)
safeHaskellOn :: DynFlags -> Bool
safeHaskellOn dflags = safeHaskell dflags /= Sf_None
safeHaskellOn dflags = safeHaskell dflags /= Sf_None || safeInferOn dflags
-- | Is the Safe Haskell safe language in use
safeLanguageOn :: DynFlags -> Bool
......@@ -1709,7 +1713,7 @@ safeLanguageOn dflags = safeHaskell dflags == Sf_Safe
-- | Is the Safe Haskell safe inference mode active
safeInferOn :: DynFlags -> Bool
safeInferOn dflags = safeHaskell dflags == Sf_SafeInferred
safeInferOn = safeInfer
-- | Test if Safe Imports are on in some form
safeImportsOn :: DynFlags -> Bool
......@@ -1723,7 +1727,11 @@ setSafeHaskell s = updM f
where f dfs = do
let sf = safeHaskell dfs
safeM <- combineSafeFlags sf s
return $ dfs { safeHaskell = safeM }
return $ case (s == Sf_Safe || s == Sf_Unsafe) of
True -> dfs { safeHaskell = safeM, safeInfer = False }
-- leave safe inferrence on in Trustworthy mode so we can warn
-- if it could have been inferred safe.
False -> dfs { safeHaskell = safeM }
-- | Are all direct imports required to be safe for this Safe Haskell mode?
-- Direct imports are when the code explicitly imports a module
......@@ -1740,9 +1748,7 @@ 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 == Sf_SafeInferred = return b
| b == Sf_SafeInferred = return a
| a == Sf_None = return b
combineSafeFlags a b | a == Sf_None = return b
| b == Sf_None = return a
| a == b = return a
| otherwise = addErr errm >> return (panic errm)
......@@ -1754,13 +1760,19 @@ combineSafeFlags a b | a == Sf_SafeInferred = return b
-- * function to get srcspan that enabled the flag
-- * function to test if the flag is on
-- * function to turn the flag off
unsafeFlags :: [(String, DynFlags -> SrcSpan, DynFlags -> Bool, DynFlags -> DynFlags)]
unsafeFlags, unsafeFlagsForInfer
:: [(String, DynFlags -> SrcSpan, DynFlags -> Bool, DynFlags -> DynFlags)]
unsafeFlags = [("-XGeneralizedNewtypeDeriving", newDerivOnLoc,
xopt Opt_GeneralizedNewtypeDeriving,
flip xopt_unset Opt_GeneralizedNewtypeDeriving),
("-XTemplateHaskell", thOnLoc,
xopt Opt_TemplateHaskell,
flip xopt_unset Opt_TemplateHaskell)]
unsafeFlagsForInfer = unsafeFlags ++
-- TODO: Can we do better than this for inference?
[("-XOverlappingInstances", overlapInstLoc,
xopt Opt_OverlappingInstances,
flip xopt_unset Opt_OverlappingInstances)]
-- | Retrieve the options corresponding to a particular @opt_*@ field in the correct order
getOpts :: DynFlags -- ^ 'DynFlags' to retrieve the options from
......@@ -2042,43 +2054,41 @@ updateWays dflags
-- The bool is to indicate if we are parsing command line flags (false means
-- file pragma). This allows us to generate better warnings.
safeFlagCheck :: Bool -> DynFlags -> (DynFlags, [Located String])
safeFlagCheck _ dflags | not (safeLanguageOn dflags || safeInferOn dflags)
= (dflags, [])
-- safe or safe-infer ON
safeFlagCheck cmdl dflags =
case safeLanguageOn dflags of
True -> (dflags', warns)
safeFlagCheck _ dflags | safeLanguageOn dflags = (dflagsUnset, warns)
where
-- Handle illegal flags under safe language.
(dflagsUnset, warns) = foldl check_method (dflags, []) unsafeFlags
-- throw error if -fpackage-trust by itself with no safe haskell flag
False | not cmdl && packageTrustOn dflags
-> (gopt_unset dflags' Opt_PackageTrust,
[L (pkgTrustOnLoc dflags') $
"-fpackage-trust ignored;" ++
" must be specified with a Safe Haskell flag"]
)
check_method (df, warns) (str,loc,test,fix)
| test df = (fix df, warns ++ safeFailure (loc df) str)
| otherwise = (df, warns)
False | null warns && safeInfOk
-> (dflags', [])
safeFailure loc str
= [L loc $ str ++ " is not allowed in Safe Haskell; ignoring "
++ str]
| otherwise
-> (dflags' { safeHaskell = Sf_None }, [])
-- Have we inferred Unsafe?
-- See Note [HscMain . Safe Haskell Inference]
where
-- TODO: Can we do better than this for inference?
safeInfOk = not $ xopt Opt_OverlappingInstances dflags
safeFlagCheck cmdl dflags =
case (safeInferOn dflags) of
True | safeFlags -> (dflags', warn)
True -> (dflags' { safeInferred = False }, warn)
False -> (dflags', warn)
(dflags', warns) = foldl check_method (dflags, []) unsafeFlags
where
-- dynflags and warn for when -fpackage-trust by itself with no safe
-- haskell flag
(dflags', warn)
| safeHaskell dflags == Sf_None && not cmdl && packageTrustOn dflags
= (gopt_unset dflags Opt_PackageTrust, pkgWarnMsg)
| otherwise = (dflags, [])
check_method (df, warns) (str,loc,test,fix)
| test df = (apFix fix df, warns ++ safeFailure (loc dflags) str)
| otherwise = (df, warns)
pkgWarnMsg = [L (pkgTrustOnLoc dflags') $
"-fpackage-trust ignored;" ++
" must be specified with a Safe Haskell flag"]
apFix f = if safeInferOn dflags then id else f
safeFlags = all (\(_,_,t,_) -> not $ t dflags) unsafeFlagsForInfer
-- Have we inferred Unsafe?
-- See Note [HscMain . Safe Haskell Inference]
safeFailure loc str
= [L loc $ str ++ " is not allowed in Safe Haskell; ignoring " ++ str]
{- **********************************************************************
%* *
......@@ -2477,7 +2487,7 @@ dynamic_flags = [
------ Safe Haskell flags -------------------------------------------
, Flag "fpackage-trust" (NoArg setPackageTrust)
, Flag "fno-safe-infer" (NoArg (setSafeHaskell Sf_None))
, Flag "fno-safe-infer" (noArg (\d -> d { safeInfer = False } ))
, Flag "fPIC" (NoArg (setGeneralFlag Opt_PIC))
, Flag "fno-PIC" (NoArg (unSetGeneralFlag Opt_PIC))
]
......
compiler/main/HscMain.hs
View file @ e69619e9
......@@ -407,19 +407,20 @@ tcRnModule' hsc_env sum save_rn_syntax mod = do
tcSafeOK <- liftIO $ readIORef (tcg_safeInfer tcg_res)
dflags <- getDynFlags
let allSafeOK = safeInferred dflags && tcSafeOK
-- 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
-- end of the safe haskell line, how to respond to user?
if not (safeHaskellOn dflags) || (safeInferOn dflags && not allSafeOK)
-- if safe Haskell off or safe infer failed, mark unsafe
then markUnsafe tcg_res emptyBag
-- module safe, throw warning if needed
-- module (could be) 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 dflags (warnSafeOnLoc dflags) $ errSafe tcg_res')
(logWarnings $ unitBag $ mkPlainWarnMsg dflags
(warnSafeOnLoc dflags) $ errSafe tcg_res')
return tcg_res'
where
pprMod t = ppr $ moduleName $ tcg_mod t
......@@ -773,16 +774,15 @@ hscCheckSafeImports tcg_env = do
tcg_env' <- checkSafeImports dflags tcg_env
case safeLanguageOn dflags of
True -> do
-- we nuke user written RULES in -XSafe
-- XSafe: we nuke user written RULES
logWarnings $ warns dflags (tcg_rules tcg_env')
return tcg_env' { tcg_rules = [] }
False
-- user defined RULES, so not safe or already unsafe
| safeInferOn dflags && not (null $ tcg_rules tcg_env') ||
safeHaskell dflags == Sf_None
-> wipeTrust tcg_env' $ warns dflags (tcg_rules tcg_env')
-- SafeInferred: user defined RULES, so not safe
| safeInferOn dflags && not (null $ tcg_rules tcg_env')
-> markUnsafe tcg_env' $ warns dflags (tcg_rules tcg_env')
-- trustworthy OR safe inferred with no RULES
-- Trustworthy OR SafeInferred: with no RULES
| otherwise
-> return tcg_env'
......@@ -828,7 +828,7 @@ checkSafeImports dflags tcg_env
True ->
-- did we fail safe inference or fail -XSafe?
case safeInferOn dflags of
True -> wipeTrust tcg_env errs
True -> markUnsafe tcg_env errs
False -> liftIO . throwIO . mkSrcErr $ errs
-- All good matey!
......@@ -849,7 +849,9 @@ checkSafeImports dflags tcg_env
condense (m, x:xs) = do (_,_,l,s) <- foldlM cond' x xs
-- we turn all imports into safe ones when
-- inference mode is on.
let s' = if safeInferOn dflags then True else s
let s' = if safeInferOn dflags &&
safeHaskell dflags == Sf_None
then True else s
return (m, l, s')
-- ImportedModsVal = (ModuleName, Bool, SrcSpan, IsSafeImport)
......@@ -915,7 +917,7 @@ hscCheckSafe' dflags m l = do
let trust = getSafeMode $ mi_trust iface'
trust_own_pkg = mi_trust_pkg iface'
-- check module is trusted
safeM = trust `elem` [Sf_SafeInferred, Sf_Safe, Sf_Trustworthy]
safeM = trust `elem` [Sf_Safe, Sf_Trustworthy]
-- check package is trusted
safeP = packageTrusted trust trust_own_pkg m
-- pkg trust reqs
......@@ -951,7 +953,6 @@ hscCheckSafe' dflags m l = do
packageTrusted _ _ _
| not (packageTrustOn dflags) = True
packageTrusted Sf_Safe False _ = True
packageTrusted Sf_SafeInferred False _ = True
packageTrusted _ _ m
| isHomePkg m = True
| otherwise = trusted $ getPackageDetails (pkgState dflags)
......@@ -998,12 +999,13 @@ checkPkgTrust dflags pkgs =
$ text "The package (" <> ppr pkg <> text ") is required" <>
text " to be trusted but it isn't!"
-- | Set module to unsafe and wipe trust information.
-- | Set module to unsafe and (potentially) wipe trust information.
--
-- Make sure to call this method to set a module to inferred unsafe,
-- it should be a central and single failure method.
wipeTrust :: TcGblEnv -> WarningMessages -> Hsc TcGblEnv
wipeTrust tcg_env whyUnsafe = do
-- it should be a central and single failure method. We only wipe the trust
-- information when we aren't in a specific Safe Haskell mode.
markUnsafe :: TcGblEnv -> WarningMessages -> Hsc TcGblEnv
markUnsafe tcg_env whyUnsafe = do
dflags <- getDynFlags
when (wopt Opt_WarnUnsafe dflags)
......@@ -1011,7 +1013,12 @@ wipeTrust tcg_env whyUnsafe = do
mkPlainWarnMsg dflags (warnUnsafeOnLoc dflags) (whyUnsafe' dflags))
liftIO $ writeIORef (tcg_safeInfer tcg_env) False
return $ tcg_env { tcg_imports = wiped_trust }
-- NOTE: Only wipe trust when not in an explicity safe haskell mode. Other
-- times inference may be on but we are in Trustworthy mode -- so we want
-- to record safe-inference failed but not wipe the trust dependencies.
case safeHaskell dflags == Sf_None of
True -> return $ tcg_env { tcg_imports = wiped_trust }
False -> return tcg_env
where
wiped_trust = (tcg_imports tcg_env) { imp_trust_pkgs = [] }
......@@ -1021,7 +1028,7 @@ wipeTrust tcg_env whyUnsafe = do
, nest 4 $ (vcat $ badFlags df) $+$
(vcat $ pprErrMsgBagWithLoc whyUnsafe)
]
badFlags df = concat $ map (badFlag df) unsafeFlags
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"]
......
compiler/main/HscTypes.lhs
View file @ e69619e9
......@@ -2494,14 +2494,15 @@ trustInfoToNum it
Sf_Unsafe -> 1
Sf_Trustworthy -> 2
Sf_Safe -> 3
Sf_SafeInferred -> 4
numToTrustInfo :: Word8 -> IfaceTrustInfo
numToTrustInfo 0 = setSafeMode Sf_None
numToTrustInfo 1 = setSafeMode Sf_Unsafe
numToTrustInfo 2 = setSafeMode Sf_Trustworthy
numToTrustInfo 3 = setSafeMode Sf_Safe
numToTrustInfo 4 = setSafeMode Sf_SafeInferred
numToTrustInfo 4 = setSafeMode Sf_Safe -- retained for backwards compat, used
-- to be Sf_SafeInfered but we no longer
-- differentiate.
numToTrustInfo n = error $ "numToTrustInfo: bad input number! (" ++ show n ++ ")"
instance Outputable IfaceTrustInfo where
......@@ -2509,7 +2510,6 @@ instance Outputable IfaceTrustInfo where
ppr (TrustInfo Sf_Unsafe) = ptext $ sLit "unsafe"
ppr (TrustInfo Sf_Trustworthy) = ptext $ sLit "trustworthy"
ppr (TrustInfo Sf_Safe) = ptext $ sLit "safe"
ppr (TrustInfo Sf_SafeInferred) = ptext $ sLit "safe-inferred"
instance Binary IfaceTrustInfo where
put_ bh iftrust = putByte bh $ trustInfoToNum iftrust
......
compiler/typecheck/TcRnMonad.lhs
View file @ e69619e9
......@@ -1205,9 +1205,10 @@ recordUnsafeInfer = getGblEnv >>= \env -> writeTcRef (tcg_safeInfer env) False
finalSafeMode :: DynFlags -> TcGblEnv -> IO SafeHaskellMode
finalSafeMode dflags tcg_env = do
safeInf <- readIORef (tcg_safeInfer tcg_env)
return $ if safeInferOn dflags && not safeInf
then Sf_None
else safeHaskell dflags
return $ case safeHaskell dflags of
Sf_None | safeInferOn dflags && safeInf -> Sf_Safe
| otherwise -> Sf_None
s -> s
\end{code}
......
testsuite/tests/safeHaskell/check/pkg01/safePkg01.stdout
View file @ e69619e9
......@@ -25,21 +25,21 @@ require own pkg trusted: True
M_SafePkg5
package dependencies: base* ghc-prim integer-gmp
trusted: safe-inferred
trusted: safe
require own pkg trusted: True
M_SafePkg6
package dependencies: array-0.4.0.1 base* bytestring-0.10.1.0*
package dependencies: array-0.5.0.0 base* bytestring-0.10.4.0*
trusted: trustworthy
require own pkg trusted: False
M_SafePkg7
package dependencies: array-0.4.0.1 base* bytestring-0.10.1.0*
package dependencies: array-0.5.0.0 base* bytestring-0.10.4.0*
trusted: safe
require own pkg trusted: False
M_SafePkg8
package dependencies: array-0.4.0.1 base bytestring-0.10.1.0*
package dependencies: array-0.5.0.0 base bytestring-0.10.4.0*
trusted: trustworthy
require own pkg trusted: False
......
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