Skip to content

GitLab

Glasgow Haskell Compiler
Glasgow Haskell Compiler
Commit e69619e9 authored by David Terei's avatar David Terei
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