Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
bb0eb57e
Commit
bb0eb57e
authored
Oct 25, 2011
by
dterei
Browse files
More updates to Safe Haskell to implement new design (done!).
parent
18d2dab6
Changes
8
Expand all
Hide whitespace changes
Inline
Side-by-side
compiler/main/DynFlags.hs
View file @
bb0eb57e
...
...
@@ -39,9 +39,9 @@ module DynFlags (
-- ** Safe Haskell
SafeHaskellMode
(
..
),
safeImportsOn
,
safeLanguageOn
,
safeDirectImpsReq
,
safeImplicitImpsReq
,
safeHaskellOn
,
safeImportsOn
,
safeLanguageOn
,
safeInferOn
,
packageTrustOn
,
safeDirectImpsReq
,
safeImplicitImpsReq
,
-- ** System tool settings and locations
Settings
(
..
),
...
...
@@ -1025,10 +1025,24 @@ 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
||
...
...
@@ -1046,33 +1060,24 @@ 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
=
safeLanguageOn
safeDirectImpsReq
d
=
safeLanguageOn
d
||
safeInferOn
d
-- | 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
=
safeLanguageOn
safeImplicitImpsReq
d
=
safeLanguageOn
d
||
safeInferOn
d
-- | 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
=
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
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
++
")"
-- | Retrieve the options corresponding to a particular @opt_*@ field in the correct order
getOpts
::
DynFlags
-- ^ 'DynFlags' to retrieve the options from
...
...
@@ -1275,21 +1280,41 @@ parseDynamicFlags dflags0 args cmdline = do
when
(
not
(
null
errs
))
$
ghcError
$
errorsToGhcException
errs
-- check for disabled flags in safe haskell
let
(
dflags2
,
sh_warns
)
=
if
(
safeLanguageOn
dflags1
)
then
shFlagsDisallowed
dflags1
else
(
dflags1
,
[]
)
let
(
dflags2
,
sh_warns
)
=
safeFlagCheck
dflags1
return
(
dflags2
,
leftover
,
sh_warns
++
warns
)
-- | 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
-- | 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'
,
[]
)
|
otherwise
->
(
dflags'
{
safeHaskell
=
Sf_None
},
[]
)
-- Have we infered Unsafe?
-- See Note [HscMain . Safe Haskell Inference]
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
=
(
fix
df
,
warns
++
safeFailure
loc
str
)
|
test
df
=
(
apFix
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
),
...
...
@@ -1297,9 +1322,6 @@ shFlagsDisallowed dflags = foldl check_method (dflags, []) bad_flags
xopt
Opt_TemplateHaskell
,
flip
xopt_unset
Opt_TemplateHaskell
)]
safeFailure
loc
str
=
[
L
loc
$
"Warning: "
++
str
++
" is not allowed in"
++
" Safe Haskell; ignoring "
++
str
]
{- **********************************************************************
%* *
...
...
@@ -1831,7 +1853,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
]
...
...
compiler/main/HscMain.lhs
View file @
bb0eb57e
This diff is collapsed.
Click to expand it.
compiler/main/HscTypes.lhs
View file @
bb0eb57e
...
...
@@ -4,6 +4,7 @@
\section[HscTypes]{Types for the per-module compiler}
\begin{code}
-- | Types for the per-module compiler
module HscTypes (
-- * compilation state
...
...
@@ -36,7 +37,6 @@ module HscTypes (
PackageInstEnv, PackageRuleBase,
-- * Annotations
prepareAnnotations,
...
...
@@ -1560,6 +1560,7 @@ 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
...
...
@@ -1567,7 +1568,8 @@ data Usage
-- ^ Cached module fingerprint
usg_safe :: IsSafeImport
-- ^ Was this module imported as a safe import
} -- ^ Module from another package
}
-- | Module from the current package
| UsageHomeModule {
usg_mod_name :: ModuleName,
-- ^ Name of the module
...
...
@@ -1582,7 +1584,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
...
...
@@ -1771,14 +1773,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
...
...
compiler/typecheck/TcForeign.lhs
View file @
bb0eb57e
...
...
@@ -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
let safe_on = safeLanguageOn dflags
|| safeInferOn 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
let safe_on = safeLanguageOn dflags
|| safeInferOn 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
let safe_on = safeLanguageOn dflags
|| safeInferOn dflags
ioOK = if safe_on then mustBeIO else nonIOok
checkForeignRes ioOK safe_on (isFFIImportResultTy dflags) res_ty
checkMissingAmpersand dflags arg_tys res_ty
...
...
@@ -377,9 +377,14 @@ checkForeignRes non_io_result_ok safehs_check pred_res_ty ty
Just (_, res_ty)
| pred_res_ty res_ty ->
return ()
_ ->
check (non_io_result_ok && pred_res_ty ty)
(illegalForeignTyErr result ty $+$ safeHsErr safehs_check)
_ -> 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)
\end{code}
\begin{code}
...
...
compiler/typecheck/TcInstDcls.lhs
View file @
bb0eb57e
...
...
@@ -407,15 +407,19 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
-- performed. Derived instances are OK.
; dflags <- getDOpts
; when (safeLanguageOn dflags) $
mapM_ (\x -> when (
is_cls (iSpec x) `elem` typeableClassNames
)
mapM_ (\x -> when (
typInstCheck x
)
(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"
...
...
compiler/typecheck/TcRnDriver.lhs
View file @
bb0eb57e
...
...
@@ -110,6 +110,7 @@ import Control.Monad
\begin{code}
-- | Top level entry point for typechecker and renamer
tcRnModule :: HscEnv
-> HscSource
-> Bool -- True <=> save renamed syntax
...
...
compiler/typecheck/TcRnMonad.lhs
View file @
bb0eb57e
...
...
@@ -2,6 +2,8 @@
% (c) The University of Glasgow 2006
%
Functions for working with the typechecker environment (setters, getters...).
\begin{code}
module TcRnMonad(
module TcRnMonad,
...
...
@@ -61,6 +63,7 @@ import Control.Monad
\begin{code}
-- | Setup the initial typechecking environment
initTc :: HscEnv
-> HscSource
-> Bool -- True <=> retain renamed syntax trees
...
...
@@ -78,6 +81,7 @@ 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 {
...
...
@@ -90,45 +94,46 @@ 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_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
} ;
lcl_env = TcLclEnv {
tcl_errs = errs_var,
...
...
@@ -271,15 +276,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
...
...
@@ -554,7 +559,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
...
...
@@ -1075,6 +1080,18 @@ 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
...
...
compiler/typecheck/TcRnTypes.lhs
View file @
bb0eb57e
...
...
@@ -2,6 +2,19 @@
% (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
...
...
@@ -135,29 +148,34 @@ instance Outputable TcTyVarBind where
%************************************************************************
%*
*
The main environment types
%*
*
%*
*
The main environment types
%*
*
%************************************************************************
\begin{code}
data Env gbl lcl -- Changes as we move into an expression
-- 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
= 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 {
...
...
@@ -198,7 +216,8 @@ data TcGblEnv
tcg_exports :: [AvailInfo], -- ^ What is exported
tcg_imports :: ImportAvails,
-- ^ Information about what was imported from where, including
-- things bound in this module.
-- things bound in this module. Also store Safe Haskell info
-- here about transative trusted packaage requirements.
tcg_dus :: DefUses,
-- ^ What is defined in this module and what is used.
...
...
@@ -280,9 +299,11 @@ 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
...
...
Ben Gamari
🐢
@bgamari
mentioned in commit
0f51b3eb
·
Oct 26, 2011
mentioned in commit
0f51b3eb
mentioned in commit 0f51b3ebcb84f786207121e0612af6bbaeaa6e92
Toggle commit list
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment