Commit 1f8b4ee0 authored by David Terei's avatar David Terei

Add in `-fwarn-trustworthy-safe` flag.

This warns when a module marked as `-XTrustworthy` could have been
inferred as safe instead.
parent 064c2896
......@@ -482,6 +482,7 @@ data WarningFlag =
| Opt_WarnAlternativeLayoutRuleTransitional
| Opt_WarnUnsafe
| Opt_WarnSafe
| Opt_WarnTrustworthySafe
| Opt_WarnPointlessPragmas
| Opt_WarnUnsupportedCallingConventions
| Opt_WarnUnsupportedLlvmVersion
......@@ -778,6 +779,7 @@ data DynFlags = DynFlags {
pkgTrustOnLoc :: SrcSpan,
warnSafeOnLoc :: SrcSpan,
warnUnsafeOnLoc :: SrcSpan,
trustworthyOnLoc :: SrcSpan,
-- Don't change this without updating extensionFlags:
extensions :: [OnOff ExtensionFlag],
-- extensionFlags should always be equal to
......@@ -1466,6 +1468,7 @@ defaultDynFlags mySettings =
pkgTrustOnLoc = noSrcSpan,
warnSafeOnLoc = noSrcSpan,
warnUnsafeOnLoc = noSrcSpan,
trustworthyOnLoc = noSrcSpan,
extensions = [],
extensionFlags = flattenExtensionFlags Nothing [],
......@@ -1758,11 +1761,15 @@ setSafeHaskell s = updM f
where f dfs = do
let sf = safeHaskell dfs
safeM <- combineSafeFlags sf s
return $ case (s == Sf_Safe || s == Sf_Unsafe) of
True -> dfs { safeHaskell = safeM, safeInfer = False }
case s of
Sf_Safe -> return $ 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 }
Sf_Trustworthy -> do
l <- getCurLoc
return $ dfs { safeHaskell = safeM, trustworthyOnLoc = l }
-- leave safe inference on in Unsafe mode as well.
_ -> return $ 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
......@@ -2663,6 +2670,7 @@ fWarningFlags = [
( "warn-overlapping-patterns", Opt_WarnOverlappingPatterns, nop ),
( "warn-pointless-pragmas", Opt_WarnPointlessPragmas, nop ),
( "warn-safe", Opt_WarnSafe, setWarnSafe ),
( "warn-trustworthy-safe", Opt_WarnTrustworthySafe, nop ),
( "warn-tabs", Opt_WarnTabs, nop ),
( "warn-type-defaults", Opt_WarnTypeDefaults, nop ),
( "warn-typed-holes", Opt_WarnTypedHoles, nop ),
......
......@@ -412,19 +412,27 @@ tcRnModule' hsc_env sum save_rn_syntax mod = do
-- 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
then markUnsafeInfer tcg_res emptyBag
-- 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')
when safe $ do
case wopt Opt_WarnSafe dflags of
True -> (logWarnings $ unitBag $ mkPlainWarnMsg dflags
(warnSafeOnLoc dflags) $ errSafe tcg_res')
False | safeHaskell dflags == Sf_Trustworthy &&
wopt Opt_WarnTrustworthySafe dflags ->
(logWarnings $ unitBag $ mkPlainWarnMsg dflags
(trustworthyOnLoc dflags) $ errTwthySafe tcg_res')
False -> return ()
return tcg_res'
where
pprMod t = ppr $ moduleName $ tcg_mod t
errSafe t = quotes (pprMod t) <+> text "has been inferred as safe!"
errTwthySafe t = quotes (pprMod t)
<+> text "is marked as Trustworthy but has been inferred as safe!"
-- | Convert a typechecked module to Core
hscDesugar :: HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts
......@@ -762,6 +770,18 @@ hscFileFrontEnd mod_summary = do
-- * For modules explicitly marked -XSafe, we throw the errors.
-- * For unmarked modules (inference mode), we drop the errors
-- and mark the module as being Unsafe.
--
-- It used to be that we only did safe inference on modules that had no Safe
-- Haskell flags, but now we perform safe inference on all modules as we want
-- to allow users to set the `--fwarn-safe`, `--fwarn-unsafe` and
-- `--fwarn-trustworthy-safe` flags on Trustworthy and Unsafe modules so that a
-- user can ensure their assumptions are correct and see reasons for why a
-- module is safe or unsafe.
--
-- This is tricky as we must be careful when we should throw an error compared
-- to just warnings. For checking safe imports we manage it as two steps. First
-- we check any imports that are required to be safe, then we check all other
-- imports to see if we can infer them to be safe.
-- | Check that the safe imports of the module being compiled are valid.
......@@ -772,21 +792,24 @@ hscCheckSafeImports :: TcGblEnv -> Hsc TcGblEnv
hscCheckSafeImports tcg_env = do
dflags <- getDynFlags
tcg_env' <- checkSafeImports dflags tcg_env
case safeLanguageOn dflags of
True -> do
-- XSafe: we nuke user written RULES
logWarnings $ warns dflags (tcg_rules tcg_env')
return tcg_env' { tcg_rules = [] }
False
-- 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 SafeInferred: with no RULES
| otherwise
-> return tcg_env'
checkRULES dflags tcg_env'
where
checkRULES dflags tcg_env' = do
case safeLanguageOn dflags of
True -> do
-- XSafe: we nuke user written RULES
logWarnings $ warns dflags (tcg_rules tcg_env')
return tcg_env' { tcg_rules = [] }
False
-- SafeInferred: user defined RULES, so not safe
| safeInferOn dflags && not (null $ tcg_rules tcg_env')
-> markUnsafeInfer tcg_env' $ warns dflags (tcg_rules tcg_env')
-- Trustworthy OR SafeInferred: with no RULES
| otherwise
-> return tcg_env'
warns dflags rules = listToBag $ map (warnRules dflags) rules
warnRules dflags (L loc (HsRule n _ _ _ _ _ _)) =
mkPlainWarnMsg dflags loc $
......@@ -808,51 +831,55 @@ hscCheckSafeImports tcg_env = do
checkSafeImports :: DynFlags -> TcGblEnv -> Hsc TcGblEnv
checkSafeImports dflags tcg_env
= do
imps <- mapM condense imports'
let (safeImps, regImps) = partition (\(_,_,s) -> s) imps
-- We want to use the warning state specifically for detecting if safe
-- inference has failed, so store and clear any existing warnings.
oldErrs <- getWarnings
clearWarnings
imps <- mapM condense imports'
pkgs <- mapM checkSafe imps
-- grab any safe haskell specific errors and restore old warnings
errs <- getWarnings
-- Check safe imports are correct
safePkgs <- mapM checkSafe safeImps
safeErrs <- getWarnings
clearWarnings
logWarnings oldErrs
-- Check non-safe imports are correct if inferring safety
-- See the Note [Safe Haskell Inference]
case (not $ isEmptyBag errs) of
-- We have errors!
True ->
-- did we fail safe inference or fail -XSafe?
case safeInferOn dflags of
True -> markUnsafe tcg_env errs
False -> liftIO . throwIO . mkSrcErr $ errs
-- All good matey!
False -> do
when (packageTrustOn dflags) $ checkPkgTrust dflags pkg_reqs
-- add in trusted package requirements for this module
let new_trust = emptyImportAvails { imp_trust_pkgs = catMaybes pkgs }
return tcg_env { tcg_imports = imp_info `plusImportAvails` new_trust }
(infErrs, infPkgs) <- case (safeInferOn dflags) of
False -> return (emptyBag, [])
True -> do infPkgs <- mapM checkSafe regImps
infErrs <- getWarnings
clearWarnings
return (infErrs, infPkgs)
-- restore old errors
logWarnings oldErrs
case (isEmptyBag safeErrs) of
-- Failed safe check
False -> liftIO . throwIO . mkSrcErr $ safeErrs
-- Passed safe check
True -> do
let infPassed = isEmptyBag infErrs
tcg_env' <- case (not infPassed) of
True -> markUnsafeInfer tcg_env infErrs
False -> return tcg_env
when (packageTrustOn dflags) $ checkPkgTrust dflags pkgReqs
let newTrust = pkgTrustReqs safePkgs infPkgs infPassed
return tcg_env' { tcg_imports = impInfo `plusImportAvails` newTrust }
where
imp_info = tcg_imports tcg_env -- ImportAvails
imports = imp_mods imp_info -- ImportedMods
impInfo = tcg_imports tcg_env -- ImportAvails
imports = imp_mods impInfo -- ImportedMods
imports' = moduleEnvToList imports -- (Module, [ImportedModsVal])
pkg_reqs = imp_trust_pkgs imp_info -- [PackageKey]
pkgReqs = imp_trust_pkgs impInfo -- [PackageKey]
condense :: (Module, [ImportedModsVal]) -> Hsc (Module, SrcSpan, IsSafeImport)
condense (_, []) = panic "HscMain.condense: Pattern match failure!"
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 &&
safeHaskell dflags == Sf_None
then True else s
return (m, l, s')
return (m, l, s)
-- ImportedModsVal = (ModuleName, Bool, SrcSpan, IsSafeImport)
cond' :: ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal
......@@ -865,8 +892,17 @@ checkSafeImports dflags tcg_env
= return v1
-- easier interface to work with
checkSafe (_, _, False) = return Nothing
checkSafe (m, l, True ) = fst `fmap` hscCheckSafe' dflags m l
checkSafe (m, l, _) = fst `fmap` hscCheckSafe' dflags m l
-- what pkg's to add to our trust requirements
pkgTrustReqs req inf infPassed | safeInferOn dflags
&& safeHaskell dflags == Sf_None && infPassed
= emptyImportAvails {
imp_trust_pkgs = catMaybes req ++ catMaybes inf
}
pkgTrustReqs _ _ _ | safeHaskell dflags == Sf_Unsafe
= emptyImportAvails
pkgTrustReqs req _ _ = emptyImportAvails { imp_trust_pkgs = catMaybes req }
-- | Check that a module is safe to import.
--
......@@ -1000,11 +1036,16 @@ checkPkgTrust dflags pkgs =
-- | 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. 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
-- Make sure to call this method to set a module to inferred unsafe, 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.
--
-- While we only use this for recording that a module was inferred unsafe, we
-- may call it on modules using Trustworthy or Unsafe flags so as to allow
-- warning flags for safety to function correctly. See Note [Safe Haskell
-- Inference].
markUnsafeInfer :: TcGblEnv -> WarningMessages -> Hsc TcGblEnv
markUnsafeInfer tcg_env whyUnsafe = do
dflags <- getDynFlags
when (wopt Opt_WarnUnsafe dflags)
......
{-# LANGUAGE Safe #-}
{-# LANGUAGE NoImplicitPrelude #-}
module ImpSafe ( MyWord ) where
module ImpSafe01 ( MyWord ) where
-- While Data.Word is safe it imports trustworthy
-- modules in base, hence base needs to be trusted.
......
{-# LANGUAGE Safe #-}
{-# LANGUAGE NoImplicitPrelude #-}
module ImpSafe ( MyWord ) where
module ImpSafe02 ( MyWord ) where
-- While Data.Word is safe it imports trustworthy
-- modules in base, hence base needs to be trusted.
......
{-# LANGUAGE Trustworthy #-}
module Main where
import safe Prelude
import safe ImpSafe03_A
main = putStrLn "test"
[2 of 2] Compiling Main ( ImpSafe03.hs, ImpSafe03.o )
<no location info>:
The package (bytestring-0.10.4.0) is required to be trusted but it isn't!
{-# LANGUAGE Trustworthy #-}
module ImpSafe03_A where
import safe Prelude
import safe qualified Data.ByteString.Char8 as BS
s = BS.pack "Hello World"
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE NoImplicitPrelude #-}
module ImpSafe04 ( MyWord ) where
-- While Data.Word is safe it imports trustworthy
-- modules in base, hence base needs to be trusted.
-- Note: Worthwhile giving out better error messages for cases
-- like this if I can.
import safe Data.Word
import System.IO.Unsafe
type MyWord = Word
ImpSafe04.hs:9:1:
Data.Word: Can't be safely imported!
The package (base-4.8.0.0) the module resides in isn't trusted.
......@@ -51,6 +51,15 @@ test('ImpSafe01', normal, compile_fail, ['-fpackage-trust -distrust base'])
# Succeed since we don't enable package trust
test('ImpSafe02', normal, compile, ['-distrust base'])
# Fail since we don't trust base of bytestring
test('ImpSafe03', normal, multi_compile_fail,
['ImpSafe03 -trust base -distrust bytestring', [
('ImpSafe03_A.hs', ' -trust base -trust bytestring')
], '-fpackage-trust' ])
# Fail same as ImpSafe01 but testing with -XTrustworthy now
test('ImpSafe04', normal, compile_fail, ['-fpackage-trust -distrust base'])
test('ImpSafeOnly01',
[pre_cmd('$MAKE -s --no-print-directory mkPackageDatabase.ImpSafeOnly01 ' + make_args),
clean_cmd('$MAKE -s --no-print-directory cleanPackageDatabase.ImpSafeOnly01')],
......@@ -95,7 +104,7 @@ test('ImpSafeOnly07',
clean_cmd('$MAKE -s --no-print-directory cleanPackageDatabase.ImpSafeOnly07'),
normalise_errmsg_fun(normaliseBytestringPackage)],
compile_fail,
['-fpackage-trust -package-db pdb.ImpSafeOnly07/local.db -trust safePkg01'])
['-fpackage-trust -package-db pdb.ImpSafeOnly07/local.db -trust safePkg01 -distrust bytestring'])
test('ImpSafeOnly08',
[pre_cmd('$MAKE -s --no-print-directory mkPackageDatabase.ImpSafeOnly08 ' + make_args),
clean_cmd('$MAKE -s --no-print-directory cleanPackageDatabase.ImpSafeOnly08'),
......
{-# LANGUAGE Unsafe #-}
{-# OPTIONS_GHC -fwarn-safe #-}
{-# OPTIONS_GHC -fwarn-unsafe #-}
{-# OPTIONS_GHC -fenable-rewrite-rules #-}
-- | Trivial Safe Module
module SafeWarn01 where
g :: Int
g = 1
SafeWarn01.hs:2:16: Warning:
‘SafeWarn01’ has been inferred as safe!
{-# LANGUAGE Trustworthy #-}
-- | This module is marked trustworthy but should be inferable as -XSafe.
-- But no warning enabled.
module TrustworthySafe01 where
g :: Int
g = 1
{-# LANGUAGE Trustworthy #-}
{-# OPTIONS_GHC -fwarn-trustworthy-safe #-}
-- | This module is marked trustworthy but should be inferable as -XSafe.
-- Warning enabled.
module TrustworthySafe02 where
g :: Int
g = 1
TrustworthySafe02.hs:1:14: Warning:
‘TrustworthySafe02’ is marked as Trustworthy but has been inferred as safe!
{-# LANGUAGE Trustworthy #-}
{-# OPTIONS_GHC -W -fno-warn-trustworthy-safe #-}
-- | This module is marked trustworthy but should be inferable as -XSafe.
-- Warning enabled through `-W` but then disabled with `-fno-warn...`.
module TrustworthySafe04 where
g :: Int
g = 1
{-# OPTIONS_GHC -fwarn-safe #-}
{-# OPTIONS_GHC -fwarn-unsafe #-}
-- | Trivial Unsafe Module
module UnsafeWarn01 where
import System.IO.Unsafe
f :: IO a -> a
f = unsafePerformIO
UnsafeWarn01.hs:2:16: Warning:
‘UnsafeWarn01’ has been inferred as unsafe!
Reason:
UnsafeWarn01.hs:7:1:
System.IO.Unsafe: Can't be safely imported!
The module itself isn't safe.
{-# OPTIONS_GHC -fwarn-safe #-}
{-# OPTIONS_GHC -fwarn-unsafe #-}
{-# LANGUAGE TemplateHaskell #-}
-- | Unsafe as uses TH
module UnsafeWarn02 where
f :: Int
f = 1
UnsafeWarn02.hs:2:16: Warning:
‘UnsafeWarn02’ has been inferred as unsafe!
Reason:
UnsafeWarn02.hs:4:14:
-XTemplateHaskell is not allowed in Safe Haskell
{-# LANGUAGE Trustworthy #-}
{-# OPTIONS_GHC -fwarn-safe #-}
{-# OPTIONS_GHC -fwarn-unsafe #-}
-- | Trivial Unsafe Module
module UnsafeWarn03 where
import System.IO.Unsafe
f :: IO a -> a
f = unsafePerformIO
UnsafeWarn03.hs:3:16: Warning:
‘UnsafeWarn03’ has been inferred as unsafe!
Reason:
UnsafeWarn03.hs:8:1:
System.IO.Unsafe: Can't be safely imported!
The module itself isn't safe.
{-# LANGUAGE Trustworthy #-}
{-# OPTIONS_GHC -fwarn-trustworthy-safe #-}
{-# OPTIONS_GHC -fwarn-unsafe #-}
-- | Trivial Unsafe Module
module UnsafeWarn04 where
import System.IO.Unsafe
f :: IO a -> a
f = unsafePerformIO
UnsafeWarn04.hs:3:16: Warning:
‘UnsafeWarn04’ has been inferred as unsafe!
Reason:
UnsafeWarn04.hs:8:1:
System.IO.Unsafe: Can't be safely imported!
The module itself isn't safe.
{-# LANGUAGE Unsafe #-}
{-# OPTIONS_GHC -fwarn-trustworthy-safe #-}
{-# OPTIONS_GHC -fwarn-safe #-}
{-# OPTIONS_GHC -fwarn-unsafe #-}
{-# OPTIONS_GHC -fenable-rewrite-rules #-}
-- | Trivial Unsafe Module
module UnsafeWarn05 where
import System.IO.Unsafe
f :: IO a -> a
f = unsafePerformIO
{-# RULES "g" g = undefined #-}
{-# NOINLINE [1] g #-}
g :: Int
g = 1
UnsafeWarn05.hs:4:16: Warning:
‘UnsafeWarn05’ has been inferred as unsafe!
Reason:
UnsafeWarn05.hs:10:1:
System.IO.Unsafe: Can't be safely imported!
The module itself isn't safe.
UnsafeWarn05.hs:4:16: Warning:
‘UnsafeWarn05’ has been inferred as unsafe!
Reason:
UnsafeWarn05.hs:15:11: Warning:
Rule "g" ignored
User defined rules are disabled under Safe Haskell
{-# OPTIONS_GHC -fenable-rewrite-rules #-}
{-# OPTIONS_GHC -fwarn-safe #-}
{-# OPTIONS_GHC -fwarn-unsafe #-}
-- | Unsafe as uses RULES
module UnsafeWarn06 where
{-# RULES "f" f = undefined #-}
{-# NOINLINE [1] f #-}
f :: Int
f = 1
UnsafeWarn06.hs:3:16: Warning:
‘UnsafeWarn06’ has been inferred as unsafe!
Reason:
UnsafeWarn06.hs:8:11: Warning:
Rule "f" ignored
User defined rules are disabled under Safe Haskell
{-# LANGUAGE Trustworthy #-}
{-# OPTIONS_GHC -fenable-rewrite-rules #-}
{-# OPTIONS_GHC -fwarn-safe #-}
{-# OPTIONS_GHC -fwarn-unsafe #-}
-- | Unsafe as uses RULES
module UnsafeWarn07 where
{-# RULES "f" f = undefined #-}
{-# NOINLINE [1] f #-}
f :: Int
f = 1
UnsafeWarn07.hs:4:16: Warning:
‘UnsafeWarn07’ has been inferred as unsafe!
Reason:
UnsafeWarn07.hs:9:11: Warning:
Rule "f" ignored
User defined rules are disabled under Safe Haskell
......@@ -73,3 +73,20 @@ test('Mixed01', normal, compile_fail, [''])
test('Mixed02', normal, compile_fail, [''])
test('Mixed03', normal, compile_fail, [''])
# Trustworthy Safe modules
test('TrustworthySafe01', normal, compile, [''])
test('TrustworthySafe02', normal, compile, [''])
test('TrustworthySafe04', normal, compile, [''])
# Check -fwarn-unsafe works
test('UnsafeWarn01', normal, compile, [''])
test('UnsafeWarn02', normal, compile, [''])
test('UnsafeWarn03', normal, compile, [''])
test('UnsafeWarn04', normal, compile, [''])
test('UnsafeWarn05', normal, compile, [''])
test('UnsafeWarn06', normal, compile, [''])
test('UnsafeWarn07', normal, compile, [''])
# Chck -fwa-safe works
test('SafeWarn01', normal, compile, [''])
{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ >= 703
{-# LANGUAGE Safe #-}
#endif
module SafeLang18 where
#define p377 toPair
data StrictPair a b = !a :*: !b
toPair :: StrictPair a b -> (a, b)
toPair (x :*: y) = (x, y)
{-# INLINE p377 #-}
......@@ -51,6 +51,8 @@ test('SafeLang17',
multimod_compile_fail,
['SafeLang17', ''])
test('SafeLang18', normal, compile, [''])
# Test building a package, that trust values are set correctly
# and can be changed correctly
#test('SafeRecomp01',
......
......@@ -2,7 +2,7 @@
-- | Import unsafe module Control.ST to make sure it fails
module Main where
import Control.Monad.ST
import Control.Monad.ST.Unsafe
f :: Int
f = 2
......