Commit 0f51b3eb authored by Ian Lynagh's avatar Ian Lynagh

Revert "More updates to Safe Haskell to implement new design (done!)."

This reverts commit bb0eb57e.
parent b558599b
......@@ -39,9 +39,9 @@ module DynFlags (
-- ** Safe Haskell
SafeHaskellMode(..),
safeHaskellOn, safeImportsOn, safeLanguageOn, safeInferOn,
packageTrustOn,
safeImportsOn, safeLanguageOn,
safeDirectImpsReq, safeImplicitImpsReq,
packageTrustOn,
-- ** System tool settings and locations
Settings(..),
......@@ -1025,24 +1025,10 @@ dynFlagDependencies = pluginModNames
packageTrustOn :: DynFlags -> Bool
packageTrustOn = dopt Opt_PackageTrust
-- | Is Safe Haskell on in some way (including inference mode)
safeHaskellOn :: DynFlags -> Bool
safeHaskellOn dflags = safeHaskell dflags /= Sf_None
-- | Is the Safe Haskell safe language in use
safeLanguageOn :: DynFlags -> Bool
safeLanguageOn dflags = safeHaskell dflags == Sf_Safe
-- | Is the Safe Haskell safe inference mode active
safeInferOn :: DynFlags -> Bool
safeInferOn dflags = safeHaskell dflags == Sf_SafeInfered
-- | Turn off Safe Haskell inference mode (set module to unsafe)
setSafeInferOff :: DynFlags -> DynFlags
setSafeInferOff dflags
| safeHaskell dflags == Sf_SafeInfered = dflags { safeHaskell = Sf_None }
| otherwise = dflags
-- | Test if Safe Imports are on in some form
safeImportsOn :: DynFlags -> Bool
safeImportsOn dflags = safeHaskell dflags == Sf_Unsafe ||
......@@ -1060,24 +1046,33 @@ setSafeHaskell s = updM f
-- | Are all direct imports required to be safe for this Safe Haskell mode?
-- Direct imports are when the code explicitly imports a module
safeDirectImpsReq :: DynFlags -> Bool
safeDirectImpsReq d = safeLanguageOn d || safeInferOn d
safeDirectImpsReq = safeLanguageOn
-- | Are all implicit imports required to be safe for this Safe Haskell mode?
-- Implicit imports are things in the prelude. e.g System.IO when print is used.
safeImplicitImpsReq :: DynFlags -> Bool
safeImplicitImpsReq d = safeLanguageOn d || safeInferOn d
safeImplicitImpsReq = safeLanguageOn
-- | Combine two Safe Haskell modes correctly. Used for dealing with multiple flags.
-- This makes Safe Haskell very much a monoid but for now I prefer this as I don't
-- 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)
where errm = "Incompatible Safe Haskell flags! ("
++ showPpr a ++ ", " ++ showPpr b ++ ")"
combineSafeFlags a b =
case (a,b) of
(Sf_None, sf) -> return sf
(sf, Sf_None) -> return sf
(Sf_SafeInfered, sf) -> return sf
(sf, Sf_SafeInfered) -> return sf
(a,b) | a == b -> return a
| otherwise -> err
where err = do
let s = "Incompatible Safe Haskell flags! (" ++ showPpr a ++ ", " ++ showPpr b ++ ")"
addErr s
return $ panic s -- Just for saftey instead of returning say, a
-- | Retrieve the options corresponding to a particular @opt_*@ field in the correct order
getOpts :: DynFlags -- ^ 'DynFlags' to retrieve the options from
......@@ -1280,41 +1275,21 @@ parseDynamicFlags dflags0 args cmdline = do
when (not (null errs)) $ ghcError $ errorsToGhcException errs
-- check for disabled flags in safe haskell
let (dflags2, sh_warns) = safeFlagCheck dflags1
return (dflags2, leftover, sh_warns ++ warns)
let (dflags2, sh_warns) = if (safeLanguageOn dflags1)
then shFlagsDisallowed dflags1
else (dflags1, [])
-- | Check (and potentially disable) any extensions that aren't allowed
-- in safe mode.
safeFlagCheck :: DynFlags -> (DynFlags, [Located String])
safeFlagCheck dflags | not (safeLanguageOn dflags || safeInferOn dflags)
= (dflags, [])
safeFlagCheck dflags =
case safeLanguageOn dflags of
True -> (dflags', warns)
False | null warns && safeInfOk
-> (dflags', [])
return (dflags2, leftover, sh_warns ++ warns)
| otherwise
-> (dflags' { safeHaskell = Sf_None }, [])
-- Have we infered Unsafe?
-- See Note [HscMain . Safe Haskell Inference]
-- | Extensions that can't be enabled at all when compiling in Safe mode
-- checkSafeHaskellFlags :: MonadIO m => DynFlags -> m ()
shFlagsDisallowed :: DynFlags -> (DynFlags, [Located String])
shFlagsDisallowed dflags = foldl check_method (dflags, []) bad_flags
where
-- TODO: Can we do better than this for inference?
safeInfOk = not $ xopt Opt_OverlappingInstances dflags
(dflags', warns) = foldl check_method (dflags, []) bad_flags
check_method (df, warns) (str,loc,test,fix)
| test df = (apFix fix df, warns ++ safeFailure loc str)
| test df = (fix df, warns ++ safeFailure loc str)
| otherwise = (df, warns)
apFix f = if safeInferOn dflags then id else f
safeFailure loc str = [L loc $ "Warning: " ++ str ++ " is not allowed in"
++ " Safe Haskell; ignoring " ++ str]
bad_flags = [("-XGeneralizedNewtypeDeriving", newDerivOnLoc dflags,
xopt Opt_GeneralizedNewtypeDeriving,
flip xopt_unset Opt_GeneralizedNewtypeDeriving),
......@@ -1322,6 +1297,9 @@ safeFlagCheck dflags =
xopt Opt_TemplateHaskell,
flip xopt_unset Opt_TemplateHaskell)]
safeFailure loc str = [L loc $ "Warning: " ++ str ++ " is not allowed in"
++ " Safe Haskell; ignoring " ++ str]
{- **********************************************************************
%* *
......@@ -1853,7 +1831,7 @@ languageFlags = [
-- features can be used.
safeHaskellFlags :: [FlagSpec SafeHaskellMode]
safeHaskellFlags = [mkF Sf_Unsafe, mkF Sf_Trustworthy, mkF Sf_Safe]
where mkF flag = (showPpr flag, flag, nop)
where mkF flag = (showPpr flag, flag, nop)
-- | These -X<blah> flags can all be reversed with -XNo<blah>
xFlags :: [FlagSpec ExtensionFlag]
......
This diff is collapsed.
......@@ -4,7 +4,6 @@
\section[HscTypes]{Types for the per-module compiler}
\begin{code}
-- | Types for the per-module compiler
module HscTypes (
-- * compilation state
......@@ -37,6 +36,7 @@ module HscTypes (
PackageInstEnv, PackageRuleBase,
-- * Annotations
prepareAnnotations,
......@@ -1560,7 +1560,6 @@ noDependencies = Deps [] [] [] []
-- | Records modules that we depend on by making a direct import from
data Usage
-- | Module from another package
= UsagePackageModule {
usg_mod :: Module,
-- ^ External package module depended on
......@@ -1568,8 +1567,7 @@ data Usage
-- ^ Cached module fingerprint
usg_safe :: IsSafeImport
-- ^ Was this module imported as a safe import
}
-- | Module from the current package
} -- ^ Module from another package
| UsageHomeModule {
usg_mod_name :: ModuleName,
-- ^ Name of the module
......@@ -1584,7 +1582,7 @@ data Usage
-- if we depend on the export list
usg_safe :: IsSafeImport
-- ^ Was this module imported as a safe import
}
} -- ^ Module from the current package
deriving( Eq )
-- The export list field is (Just v) if we depend on the export list:
-- i.e. we imported the module directly, whether or not we
......@@ -1773,14 +1771,14 @@ ms_imps ms = ms_textual_imps ms ++ map mk_additional_import (dynFlagDependencies
-- import that did not occur in the program text, such as those induced by the use of
-- plugins (the -plgFoo flag)
mk_additional_import mod_nm = noLoc $ ImportDecl {
ideclName = noLoc mod_nm,
ideclPkgQual = Nothing,
ideclSource = False,
ideclImplicit = True, -- Maybe implicit because not "in the program text"
ideclName = noLoc mod_nm,
ideclPkgQual = Nothing,
ideclSource = False,
ideclImplicit = True, -- Maybe implicit because not "in the program text"
ideclQualified = False,
ideclAs = Nothing,
ideclHiding = Nothing,
ideclSafe = False
ideclAs = Nothing,
ideclHiding = Nothing,
ideclSafe = False
}
-- The ModLocation contains both the original source filename and the
......
......@@ -236,7 +236,7 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ (CFunction tar
check (isFFIDynArgumentTy arg1_ty)
(illegalForeignTyErr argument arg1_ty)
checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
let safe_on = safeLanguageOn dflags || safeInferOn dflags
let safe_on = safeLanguageOn dflags
ioOK = if safe_on then mustBeIO else nonIOok
checkForeignRes ioOK safe_on (isFFIImportResultTy dflags) res_ty
return idecl
......@@ -250,17 +250,17 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ (CFunction tar
(text "The safe/unsafe annotation should not be used with `foreign import prim'.")
checkForeignArgs (isFFIPrimArgumentTy dflags) arg_tys
-- prim import result is more liberal, allows (#,,#)
let safe_on = safeLanguageOn dflags || safeInferOn dflags
let safe_on = safeLanguageOn dflags
ioOK = if safe_on then mustBeIO else nonIOok
checkForeignRes ioOK safe_on (isFFIPrimResultTy dflags) res_ty
return idecl
| otherwise = do -- Normal foreign import
checkCg checkCOrAsmOrLlvmOrDotNetOrInterp
checkCg (checkCOrAsmOrLlvmOrDotNetOrInterp)
checkCConv cconv
checkCTarget target
dflags <- getDOpts
checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
let safe_on = safeLanguageOn dflags || safeInferOn dflags
let safe_on = safeLanguageOn dflags
ioOK = if safe_on then mustBeIO else nonIOok
checkForeignRes ioOK safe_on (isFFIImportResultTy dflags) res_ty
checkMissingAmpersand dflags arg_tys res_ty
......@@ -377,14 +377,9 @@ checkForeignRes non_io_result_ok safehs_check pred_res_ty ty
Just (_, res_ty)
| pred_res_ty res_ty ->
return ()
_ -> do
dflags <- getDOpts
case safeInferOn dflags && safehs_check of
True | pred_res_ty ty -> recordUnsafeInfer
_ -> check (non_io_result_ok && pred_res_ty ty)
(illegalForeignTyErr result ty $+$ safeHsErr safehs_check)
_ ->
check (non_io_result_ok && pred_res_ty ty)
(illegalForeignTyErr result ty $+$ safeHsErr safehs_check)
\end{code}
\begin{code}
......
......@@ -407,19 +407,15 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
-- performed. Derived instances are OK.
; dflags <- getDOpts
; when (safeLanguageOn dflags) $
mapM_ (\x -> when (typInstCheck x)
mapM_ (\x -> when (is_cls (iSpec x) `elem` typeableClassNames)
(addErrAt (getSrcSpan $ iSpec x) typInstErr))
local_info
-- As above but for Safe Inference mode.
; when (safeInferOn dflags) $
mapM_ (\x -> when (typInstCheck x) recordUnsafeInfer) local_info
; return ( gbl_env
, (bagToList deriv_inst_info) ++ local_info
, aux_binds `plusHsValBinds` deriv_binds)
}}}
where
typInstCheck ty = is_cls (iSpec ty) `elem` typeableClassNames
typInstErr = ptext $ sLit $ "Can't create hand written instances of Typeable in Safe"
++ " Haskell! Can only derive them"
......
......@@ -110,7 +110,6 @@ import Control.Monad
\begin{code}
-- | Top level entry point for typechecker and renamer
tcRnModule :: HscEnv
-> HscSource
-> Bool -- True <=> save renamed syntax
......
......@@ -2,8 +2,6 @@
% (c) The University of Glasgow 2006
%
Functions for working with the typechecker environment (setters, getters...).
\begin{code}
module TcRnMonad(
module TcRnMonad,
......@@ -63,7 +61,6 @@ import Control.Monad
\begin{code}
-- | Setup the initial typechecking environment
initTc :: HscEnv
-> HscSource
-> Bool -- True <=> retain renamed syntax trees
......@@ -81,7 +78,6 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
used_rdr_var <- newIORef Set.empty ;
th_var <- newIORef False ;
th_splice_var<- newIORef False ;
infer_var <- newIORef True ;
lie_var <- newIORef emptyWC ;
dfun_n_var <- newIORef emptyOccSet ;
type_env_var <- case hsc_type_env_var hsc_env of {
......@@ -94,46 +90,45 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
| otherwise = Nothing ;
gbl_env = TcGblEnv {
tcg_mod = mod,
tcg_src = hsc_src,
tcg_rdr_env = emptyGlobalRdrEnv,
tcg_fix_env = emptyNameEnv,
tcg_field_env = RecFields emptyNameEnv emptyNameSet,
tcg_default = Nothing,
tcg_type_env = emptyNameEnv,
tcg_type_env_var = type_env_var,
tcg_inst_env = emptyInstEnv,
tcg_fam_inst_env = emptyFamInstEnv,
tcg_th_used = th_var,
tcg_th_splice_used = th_splice_var,
tcg_exports = [],
tcg_imports = emptyImportAvails,
tcg_used_rdrnames = used_rdr_var,
tcg_dus = emptyDUs,
tcg_rn_imports = [],
tcg_rn_exports = maybe_rn_syntax [],
tcg_rn_decls = maybe_rn_syntax emptyRnGroup,
tcg_binds = emptyLHsBinds,
tcg_imp_specs = [],
tcg_sigs = emptyNameSet,
tcg_ev_binds = emptyBag,
tcg_warns = NoWarnings,
tcg_anns = [],
tcg_tcs = [],
tcg_clss = [],
tcg_insts = [],
tcg_fam_insts = [],
tcg_rules = [],
tcg_fords = [],
tcg_vects = [],
tcg_dfun_n = dfun_n_var,
tcg_keep = keep_var,
tcg_doc_hdr = Nothing,
tcg_hpc = False,
tcg_main = Nothing,
tcg_safeInfer = infer_var
tcg_mod = mod,
tcg_src = hsc_src,
tcg_rdr_env = emptyGlobalRdrEnv,
tcg_fix_env = emptyNameEnv,
tcg_field_env = RecFields emptyNameEnv emptyNameSet,
tcg_default = Nothing,
tcg_type_env = emptyNameEnv,
tcg_type_env_var = type_env_var,
tcg_inst_env = emptyInstEnv,
tcg_fam_inst_env = emptyFamInstEnv,
tcg_th_used = th_var,
tcg_th_splice_used = th_splice_var,
tcg_exports = [],
tcg_imports = emptyImportAvails,
tcg_used_rdrnames = used_rdr_var,
tcg_dus = emptyDUs,
tcg_rn_imports = [],
tcg_rn_exports = maybe_rn_syntax [],
tcg_rn_decls = maybe_rn_syntax emptyRnGroup,
tcg_binds = emptyLHsBinds,
tcg_imp_specs = [],
tcg_sigs = emptyNameSet,
tcg_ev_binds = emptyBag,
tcg_warns = NoWarnings,
tcg_anns = [],
tcg_tcs = [],
tcg_clss = [],
tcg_insts = [],
tcg_fam_insts = [],
tcg_rules = [],
tcg_fords = [],
tcg_vects = [],
tcg_dfun_n = dfun_n_var,
tcg_keep = keep_var,
tcg_doc_hdr = Nothing,
tcg_hpc = False,
tcg_main = Nothing
} ;
lcl_env = TcLclEnv {
tcl_errs = errs_var,
......@@ -276,15 +271,15 @@ unsetWOptM flag = updEnv (\ env@(Env { env_top = top }) ->
-- | Do it flag is true
ifDOptM :: DynFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
ifDOptM flag thing_inside = do { b <- doptM flag ;
ifDOptM flag thing_inside = do { b <- doptM flag;
if b then thing_inside else return () }
ifWOptM :: WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
ifWOptM flag thing_inside = do { b <- woptM flag ;
ifWOptM flag thing_inside = do { b <- woptM flag;
if b then thing_inside else return () }
ifXOptM :: ExtensionFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
ifXOptM flag thing_inside = do { b <- xoptM flag ;
ifXOptM flag thing_inside = do { b <- xoptM flag;
if b then thing_inside else return () }
getGhcMode :: TcRnIf gbl lcl GhcMode
......@@ -559,7 +554,7 @@ setErrsVar :: TcRef Messages -> TcRn a -> TcRn a
setErrsVar v = updLclEnv (\ env -> env { tcl_errs = v })
addErr :: Message -> TcRn () -- Ignores the context stack
addErr msg = do { loc <- getSrcSpanM; addErrAt loc msg }
addErr msg = do { loc <- getSrcSpanM ; addErrAt loc msg }
failWith :: Message -> TcRn a
failWith msg = addErr msg >> failM
......@@ -1080,18 +1075,6 @@ setStage s = updLclEnv (\ env -> env { tcl_th_ctxt = s })
\end{code}
%************************************************************************
%* *
Safe Haskell context
%* *
%************************************************************************
\begin{code}
recordUnsafeInfer :: TcM ()
recordUnsafeInfer = getGblEnv >>= \env -> writeTcRef (tcg_safeInfer env) False
\end{code}
%************************************************************************
%* *
Stuff for the renamer's local env
......
......@@ -2,19 +2,6 @@
% (c) The University of Glasgow 2006
% (c) The GRASP Project, Glasgow University, 1992-2002
%
Various types used during typechecking, please see TcRnMonad as well for
operations on these types. You probably want to import it, instead of this
module.
All the monads exported here are built on top of the same IOEnv monad. The
monad functions like a Reader monad in the way it passes the environment
around. This is done to allow the environment to be manipulated in a stack
like fashion when entering expressions... ect.
For state that is global and should be returned at the end (e.g not part
of the stack mechanism), you should use an TcRef (= IORef) to store them.
\begin{code}
module TcRnTypes(
TcRnIf, TcRn, TcM, RnM, IfM, IfL, IfG, -- The monad is opaque outside this module
......@@ -148,34 +135,29 @@ instance Outputable TcTyVarBind where
%************************************************************************
%* *
The main environment types
%* *
%* *
The main environment types
%* *
%************************************************************************
\begin{code}
-- We 'stack' these envs through the Reader like monad infastructure
-- as we move into an expression (although the change is focused in
-- the lcl type).
data Env gbl lcl
data Env gbl lcl -- Changes as we move into an expression
= Env {
env_top :: HscEnv, -- Top-level stuff that never changes
-- Includes all info about imported things
env_top :: HscEnv, -- Top-level stuff that never changes
-- Includes all info about imported things
env_us :: {-# UNPACK #-} !(IORef UniqSupply),
-- Unique supply for local varibles
env_us :: {-# UNPACK #-} !(IORef UniqSupply),
-- Unique supply for local varibles
env_gbl :: gbl, -- Info about things defined at the top level
-- of the module being compiled
env_gbl :: gbl, -- Info about things defined at the top level
-- of the module being compiled
env_lcl :: lcl -- Nested stuff; changes as we go into
env_lcl :: lcl -- Nested stuff; changes as we go into
}
-- TcGblEnv describes the top-level of the module at the
-- point at which the typechecker is finished work.
-- It is this structure that is handed on to the desugarer
-- For state that needs to be updated during the typechecking
-- phase and returned at end, use a TcRef (= IORef).
data TcGblEnv
= TcGblEnv {
......@@ -216,8 +198,7 @@ data TcGblEnv
tcg_exports :: [AvailInfo], -- ^ What is exported
tcg_imports :: ImportAvails,
-- ^ Information about what was imported from where, including
-- things bound in this module. Also store Safe Haskell info
-- here about transative trusted packaage requirements.
-- things bound in this module.
tcg_dus :: DefUses,
-- ^ What is defined in this module and what is used.
......@@ -299,11 +280,9 @@ data TcGblEnv
tcg_hpc :: AnyHpcUsage, -- ^ @True@ if any part of the
-- prog uses hpc instrumentation.
tcg_main :: Maybe Name, -- ^ The Name of the main
tcg_main :: Maybe Name -- ^ The Name of the main
-- function, if this module is
-- the main module.
tcg_safeInfer :: TcRef Bool -- Has the typechecker infered this
-- module as -XSafe (Safe Haskell)
}
data RecFieldEnv
......
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