Skip to content

GitLab

GHC
GHC
Commit 6de1b0f2 authored by dterei's avatar dterei
Browse files
Options

SafeHaskell: Add safe import flag (not functional)

parent f8279ea9
Hide whitespace changes
Inline Side-by-side
Showing with 97 additions and 51 deletions
compiler/hsSyn/HsImpExp.lhs
View file @ 6de1b0f2
......@@ -36,6 +36,7 @@ data ImportDecl name
ideclName :: Located ModuleName, -- ^ Module name.
ideclPkgQual :: Maybe FastString, -- ^ Package qualifier.
ideclSource :: Bool, -- ^ True <=> {-# SOURCE #-} import
ideclSafe :: Bool, -- ^ True => safe import
ideclQualified :: Bool, -- ^ True => qualified
ideclAs :: Maybe ModuleName, -- ^ as Module
ideclHiding :: Maybe (Bool, [LIE name]) -- ^ (True => hiding, names)
......@@ -54,9 +55,9 @@ simpleImportDecl mn = ImportDecl {
\begin{code}
instance (Outputable name) => Outputable (ImportDecl name) where
ppr (ImportDecl mod pkg from qual as spec)
= hang (hsep [ptext (sLit "import"), ppr_imp from,
pp_qual qual, pp_pkg pkg, ppr mod, pp_as as])
ppr (ImportDecl mod' pkg from safe qual as spec)
= hang (hsep [ptext (sLit "import"), ppr_imp from, pp_safe safe,
pp_qual qual, pp_pkg pkg, ppr mod', pp_as as])
4 (pp_spec spec)
where
pp_pkg Nothing = empty
......@@ -65,6 +66,9 @@ instance (Outputable name) => Outputable (ImportDecl name) where
pp_qual False = empty
pp_qual True = ptext (sLit "qualified")
pp_safe False = empty
pp_safe True = ptext (sLit "safe")
pp_as Nothing = empty
pp_as (Just a) = ptext (sLit "as") <+> ppr a
......
compiler/iface/BinIface.hs
View file @ 6de1b0f2
......@@ -511,12 +511,14 @@ instance Binary Usage where
putByte bh 0
put_ bh (usg_mod usg)
put_ bh (usg_mod_hash usg)
put_ bh (usg_safe usg)
put_ bh usg@UsageHomeModule{} = do
putByte bh 1
put_ bh (usg_mod_name usg)
put_ bh (usg_mod_hash usg)
put_ bh (usg_exports usg)
put_ bh (usg_entities usg)
put_ bh (usg_safe usg)
get bh = do
h <- getByte bh
......@@ -524,14 +526,16 @@ instance Binary Usage where
0 -> do
nm <- get bh
mod <- get bh
return UsagePackageModule { usg_mod = nm, usg_mod_hash = mod }
safe <- get bh
return UsagePackageModule { usg_mod = nm, usg_mod_hash = mod, usg_safe = safe }
_ -> do
nm <- get bh
mod <- get bh
exps <- get bh
ents <- get bh
safe <- get bh
return UsageHomeModule { usg_mod_name = nm, usg_mod_hash = mod,
usg_exports = exps, usg_entities = ents }
usg_exports = exps, usg_entities = ents, usg_safe = safe }
instance Binary Warnings where
put_ bh NoWarnings = putByte bh 0
......
compiler/iface/LoadIface.lhs
View file @ 6de1b0f2
......@@ -697,16 +697,22 @@ pprExport (mod, items)
pprUsage :: Usage -> SDoc
pprUsage usage@UsagePackageModule{}
= hsep [ptext (sLit "import"), ppr (usg_mod usage),
ppr (usg_mod_hash usage)]
= pprUsageImport usage usg_mod
pprUsage usage@UsageHomeModule{}
= hsep [ptext (sLit "import"), ppr (usg_mod_name usage),
ppr (usg_mod_hash usage)] $$
= pprUsageImport usage usg_mod_name $$
nest 2 (
maybe empty (\v -> text "exports: " <> ppr v) (usg_exports usage) $$
vcat [ ppr n <+> ppr v | (n,v) <- usg_entities usage ]
)
pprUsageImport :: Outputable a => Usage -> (Usage -> a) -> SDoc
pprUsageImport usage usg_mod'
= hsep [ptext (sLit "import"), safe, ppr (usg_mod' usage),
ppr (usg_mod_hash usage)]
where
safe | usg_safe usage = ptext $ sLit "safe"
| otherwise = ptext $ sLit " -/ "
pprDeps :: Dependencies -> SDoc
pprDeps (Deps { dep_mods = mods, dep_pkgs = pkgs, dep_orphs = orphs,
dep_finsts = finsts })
......
compiler/iface/MkIface.lhs
View file @ 6de1b0f2
......@@ -873,7 +873,8 @@ mk_usage_info pit hsc_env this_mod direct_imports used_names
| modulePackageId mod /= this_pkg
= Just UsagePackageModule{ usg_mod = mod,
usg_mod_hash = mod_hash }
usg_mod_hash = mod_hash,
usg_safe = imp_safe }
-- for package modules, we record the module hash only
| (null used_occs
......@@ -888,22 +889,27 @@ mk_usage_info pit hsc_env this_mod direct_imports used_names
| otherwise
= Just UsageHomeModule {
usg_mod_name = moduleName mod,
usg_mod_hash = mod_hash,
usg_exports = export_hash,
usg_entities = Map.toList ent_hashs }
usg_mod_hash = mod_hash,
usg_exports = export_hash,
usg_entities = Map.toList ent_hashs,
usg_safe = imp_safe }
where
maybe_iface = lookupIfaceByModule dflags hpt pit mod
-- In one-shot mode, the interfaces for home-package
-- modules accumulate in the PIT not HPT. Sigh.
is_direct_import = mod `elemModuleEnv` direct_imports
maybe_iface = lookupIfaceByModule dflags hpt pit mod
-- In one-shot mode, the interfaces for home-package
-- modules accumulate in the PIT not HPT. Sigh.
Just iface = maybe_iface
finsts_mod = mi_finsts iface
hash_env = mi_hash_fn iface
mod_hash = mi_mod_hash iface
export_hash | depend_on_exports = Just (mi_exp_hash iface)
| otherwise = Nothing
| otherwise = Nothing
(is_direct_import, imp_safe)
= case lookupModuleEnv direct_imports mod of
Just ((_,_,_,safe):xs) -> (True, safe)
Just _ -> pprPanic "mkUsage: empty direct import" empty
Nothing -> (False, False)
used_occs = lookupModuleEnv ent_map mod `orElse` []
......@@ -1158,7 +1164,7 @@ checkDependencies hsc_env summary iface
orM = foldr f (return False)
where f m rest = do b <- m; if b then return True else rest
dep_missing (L _ (ImportDecl (L _ mod) pkg _ _ _ _)) = do
dep_missing (L _ (ImportDecl (L _ mod) pkg _ _ _ _ _)) = do
find_res <- liftIO $ findImportedModule hsc_env mod pkg
case find_res of
Found _ mod
......
compiler/main/DynFlags.hs
View file @ 6de1b0f2
......@@ -32,6 +32,7 @@ module DynFlags (
DPHBackend(..), dphPackageMaybe,
wayNames,
SafeHaskellMode(..),
safeHaskellOn,
Settings(..),
ghcUsagePath, ghciUsagePath, topDir, tmpDir, rawSettings,
......@@ -962,6 +963,7 @@ xopt_unset dfs f
in dfs { extensions = onoffs,
extensionFlags = flattenExtensionFlags (language dfs) onoffs }
-- | Set the Haskell language standard to use
setLanguage :: Language -> DynP ()
setLanguage l = upd f
where f dfs = let mLang = Just l
......@@ -971,6 +973,10 @@ setLanguage l = upd f
extensionFlags = flattenExtensionFlags mLang oneoffs
}
-- | Test if SafeHaskell is on in some form
safeHaskellOn :: DynFlags -> Bool
safeHaskellOn dflags = safeHaskell dflags /= Sf_None
-- | Set a 'SafeHaskell' flag
setSafeHaskell :: SafeHaskellMode -> DynP ()
setSafeHaskell s = upd f
......
compiler/main/HeaderInfo.hs
View file @ 6de1b0f2
......@@ -98,7 +98,7 @@ mkPrelImports this_mod implicit_prelude import_decls
| otherwise = [preludeImportDecl]
where
explicit_prelude_import
= notNull [ () | L _ (ImportDecl mod Nothing _ _ _ _) <- import_decls,
= notNull [ () | L _ (ImportDecl mod Nothing _ _ _ _ _) <- import_decls,
unLoc mod == pRELUDE_NAME ]
preludeImportDecl :: LImportDecl RdrName
......@@ -107,6 +107,7 @@ mkPrelImports this_mod implicit_prelude import_decls
ImportDecl (L loc pRELUDE_NAME)
Nothing {- no specific package -}
False {- Not a boot interface -}
False {- Not a safe interface -}
False {- Not qualified -}
Nothing {- No "as" -}
Nothing {- No import list -}
......
compiler/main/HscStats.lhs
View file @ 6de1b0f2
......@@ -32,12 +32,13 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
[("ExportAll ", export_all), -- 1 if no export list
("ExportDecls ", export_ds),
("ExportModules ", export_ms),
("Imports ", import_no),
(" ImpQual ", import_qual),
(" ImpAs ", import_as),
(" ImpAll ", import_all),
(" ImpPartial ", import_partial),
(" ImpHiding ", import_hiding),
("Imports ", imp_no),
(" ImpSafe ", imp_safe),
(" ImpQual ", imp_qual),
(" ImpAs ", imp_as),
(" ImpAll ", imp_all),
(" ImpPartial ", imp_partial),
(" ImpHiding ", imp_hiding),
("FixityDecls ", fixity_sigs),
("DefaultDecls ", default_ds),
("TypeDecls ", type_ds),
......@@ -99,8 +100,8 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
(val_bind_ds, fn_bind_ds)
= foldr add2 (0,0) (map count_bind val_decls)
(import_no, import_qual, import_as, import_all, import_partial, import_hiding)
= foldr add6 (0,0,0,0,0,0) (map import_info imports)
(imp_no, imp_safe, imp_qual, imp_as, imp_all, imp_partial, imp_hiding)
= foldr add7 (0,0,0,0,0,0,0) (map import_info imports)
(data_constrs, data_derivs)
= foldr add2 (0,0) (map data_info tycl_decls)
(class_method_ds, default_method_ds)
......@@ -122,15 +123,16 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
sig_info (GenericSig _ _) = (0,0,0,0,1)
sig_info _ = (0,0,0,0,0)
import_info (L _ (ImportDecl _ _ _ qual as spec))
= add6 (1, qual_info qual, as_info as, 0,0,0) (spec_info spec)
import_info (L _ (ImportDecl _ _ _ safe qual as spec))
= add7 (1, safe_info safe, qual_info qual, as_info as, 0,0,0) (spec_info spec)
safe_info = qual_info
qual_info False = 0
qual_info True = 1
as_info Nothing = 0
as_info (Just _) = 1
spec_info Nothing = (0,0,0,1,0,0)
spec_info (Just (False, _)) = (0,0,0,0,1,0)
spec_info (Just (True, _)) = (0,0,0,0,0,1)
spec_info Nothing = (0,0,0,0,1,0,0)
spec_info (Just (False, _)) = (0,0,0,0,0,1,0)
spec_info (Just (True, _)) = (0,0,0,0,0,0,1)
data_info (TyData {tcdCons = cs, tcdDerivs = derivs})
= (length cs, case derivs of Nothing -> 0
......@@ -160,12 +162,12 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
addpr :: (Int,Int) -> Int
add2 :: (Int,Int) -> (Int,Int) -> (Int, Int)
add5 :: (Int,Int,Int,Int,Int) -> (Int,Int,Int,Int,Int) -> (Int, Int, Int, Int, Int)
add6 :: (Int,Int,Int,Int,Int,Int) -> (Int,Int,Int,Int,Int,Int) -> (Int, Int, Int, Int, Int, Int)
add7 :: (Int,Int,Int,Int,Int,Int,Int) -> (Int,Int,Int,Int,Int,Int,Int) -> (Int, Int, Int, Int, Int, Int, Int)
addpr (x,y) = x+y
add2 (x1,x2) (y1,y2) = (x1+y1,x2+y2)
add5 (x1,x2,x3,x4,x5) (y1,y2,y3,y4,y5) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5)
add6 (x1,x2,x3,x4,x5,x6) (y1,y2,y3,y4,y5,y6) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5,x6+y6)
add7 (x1,x2,x3,x4,x5,x6,x7) (y1,y2,y3,y4,y5,y6,y7) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5,x6+y6,x7+y7)
\end{code}
......
compiler/main/HscTypes.lhs
View file @ 6de1b0f2
......@@ -93,7 +93,7 @@ module HscTypes (
-- * Safe Haskell information
IfaceTrustInfo, getSafeMode, setSafeMode, noIfaceTrustInfo,
trustInfoToNum, numToTrustInfo,
trustInfoToNum, numToTrustInfo, IsSafeImport,
-- * Compilation errors and warnings
SourceError, GhcApiError, mkSrcErr, srcErrorMessages, mkApiErr,
......@@ -718,7 +718,7 @@ emptyModDetails = ModDetails { md_types = emptyTypeEnv,
}
-- | Records the modules directly imported by a module for extracting e.g. usage information
type ImportedMods = ModuleEnv [(ModuleName, Bool, SrcSpan)]
type ImportedMods = ModuleEnv [(ModuleName, Bool, SrcSpan, IsSafeImport)]
-- TODO: we are not actually using the codomain of this type at all, so it can be
-- replaced with ModuleEnv ()
......@@ -1456,7 +1456,10 @@ data Usage
= UsagePackageModule {
usg_mod :: Module,
-- ^ External package module depended on
usg_mod_hash :: Fingerprint
usg_mod_hash :: Fingerprint,
-- ^ Cached module fingerprint
usg_safe :: IsSafeImport
-- ^ Was this module imported as a safe import
} -- ^ Module from another package
| UsageHomeModule {
usg_mod_name :: ModuleName,
......@@ -1467,9 +1470,11 @@ data Usage
-- ^ Entities we depend on, sorted by occurrence name and fingerprinted.
-- NB: usages are for parent names only, e.g. type constructors
-- but not the associated data constructors.
usg_exports :: Maybe Fingerprint
usg_exports :: Maybe Fingerprint,
-- ^ Fingerprint for the export list we used to depend on this module,
-- 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:
......@@ -1810,6 +1815,9 @@ This stuff here is related to supporting the Safe Haskell extension,
primarily about storing under what trust type a module has been compiled.
\begin{code}
-- | Is an import a safe import?
type IsSafeImport = Bool
-- | Safe Haskell information for 'ModIface'
-- Simply a wrapper around SafeHaskellMode to sepperate iface and flags
newtype IfaceTrustInfo = TrustInfo SafeHaskellMode
......
compiler/parser/Lexer.x
View file @ 6de1b0f2
......@@ -661,7 +661,7 @@ reservedWordsFM = listToUFM $
( "export", ITexport, bit ffiBit),
( "label", ITlabel, bit ffiBit),
( "dynamic", ITdynamic, bit ffiBit),
( "safe", ITsafe, bit ffiBit),
( "safe", ITsafe, bit ffiBit .|. bit safeHaskellBit),
( "threadsafe", ITthreadsafe, bit ffiBit), -- ToDo: remove
( "interruptible", ITinterruptible, bit ffiBit),
( "unsafe", ITunsafe, bit ffiBit),
......@@ -1807,6 +1807,8 @@ relaxedLayoutBit :: Int
relaxedLayoutBit = 24
nondecreasingIndentationBit :: Int
nondecreasingIndentationBit = 25
safeHaskellBit :: Int
safeHaskellBit = 26
always :: Int -> Bool
always _ = True
......@@ -1902,6 +1904,7 @@ mkPState flags buf loc =
.|. alternativeLayoutRuleBit `setBitIf` xopt Opt_AlternativeLayoutRule flags
.|. relaxedLayoutBit `setBitIf` xopt Opt_RelaxedLayout flags
.|. nondecreasingIndentationBit `setBitIf` xopt Opt_NondecreasingIndentation flags
.|. safeHaskellBit `setBitIf` safeHaskellOn flags
--
setBitIf :: Int -> Bool -> Int
b `setBitIf` cond | cond = bit b
......
compiler/parser/Parser.y.pp
View file @ 6de1b0f2
......@@ -500,13 +500,17 @@ importdecls :: { [LImportDecl RdrName] }
| {- empty -} { [] }
importdecl :: { LImportDecl RdrName }
: 'import' maybe_src optqualified maybe_pkg modid maybeas maybeimpspec
{ L (comb4 $1 $5 $6 $7) (ImportDecl $5 $4 $2 $3 (unLoc $6) (unLoc $7)) }
: 'import' maybe_src maybe_safe optqualified maybe_pkg modid maybeas maybeimpspec
{ L (comb4 $1 $6 $7 $8) (ImportDecl $6 $5 $2 $3 $4 (unLoc $7) (unLoc $8)) }
maybe_src :: { IsBootInterface }
: '{-# SOURCE' '#-}' { True }
| {- empty -} { False }
maybe_safe :: { Bool }
: 'safe' { True }
| {- empty -} { False }
maybe_pkg :: { Maybe FastString }
: STRING { Just (getSTRING $1) }
| {- empty -} { Nothing }
......
compiler/rename/RnNames.lhs
View file @ 6de1b0f2
......@@ -65,7 +65,7 @@ rnImports imports
implicit_prelude <- xoptM Opt_ImplicitPrelude
let prel_imports = mkPrelImports (moduleName this_mod) implicit_prelude imports
(source, ordinary) = partition is_source_import imports
is_source_import (L _ (ImportDecl _ _ is_boot _ _ _)) = is_boot
is_source_import (L _ (ImportDecl _ _ is_boot _ _ _ _)) = is_boot
ifDOptM Opt_WarnImplicitPrelude (
when (notNull prel_imports) $ addWarn (implicitPreludeWarn)
......@@ -94,7 +94,8 @@ rnImportDecl :: Module -> Bool
rnImportDecl this_mod implicit_prelude
(L loc (ImportDecl { ideclName = loc_imp_mod_name, ideclPkgQual = mb_pkg
, ideclSource = want_boot, ideclQualified = qual_only
, ideclSource = want_boot, ideclSafe = mod_safe
, ideclQualified = qual_only
, ideclAs = as_mod, ideclHiding = imp_details }))
= setSrcSpan loc $ do
......@@ -219,7 +220,7 @@ rnImportDecl this_mod implicit_prelude
_ -> False
imports = ImportAvails {
imp_mods = unitModuleEnv imp_mod [(qual_mod_name, import_all, loc)],
imp_mods = unitModuleEnv imp_mod [(qual_mod_name, import_all, loc, mod_safe)],
imp_orphs = orphans,
imp_finsts = finsts,
imp_dep_mods = mkModDeps dependent_mods,
......@@ -233,7 +234,7 @@ rnImportDecl this_mod implicit_prelude
_ -> return ()
)
let new_imp_decl = L loc (ImportDecl loc_imp_mod_name mb_pkg want_boot
let new_imp_decl = L loc (ImportDecl loc_imp_mod_name mb_pkg want_boot mod_safe
qual_only as_mod new_imp_details)
return (new_imp_decl, gbl_env, imports, mi_hpc iface)
......@@ -908,7 +909,7 @@ exports_from_avail (Just rdr_items) rdr_env imports this_mod
imported_modules = [ qual_name
| xs <- moduleEnvElts $ imp_mods imports,
(qual_name, _, _) <- xs ]
(qual_name, _, _, _) <- xs ]
exports_from_item :: ExportAccum -> LIE RdrName -> RnM ExportAccum
exports_from_item acc@(ie_names, occs, exports)
......
compiler/typecheck/TcRnMonad.lhs
View file @ 6de1b0f2
......@@ -84,8 +84,8 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
maybe_rn_syntax :: forall a. a -> Maybe a ;
maybe_rn_syntax empty_val
| keep_rn_syntax = Just empty_val
| otherwise = Nothing ;
| otherwise = Nothing ;
gbl_env = TcGblEnv {
tcg_mod = mod,
tcg_src = hsc_src,
......
compiler/typecheck/TcRnTypes.lhs
View file @ 6de1b0f2
......@@ -571,7 +571,8 @@ type ErrCtxt = (Bool, TidyEnv -> TcM (TidyEnv, Message))
--
data ImportAvails
= ImportAvails {
imp_mods :: ModuleEnv [(ModuleName, Bool, SrcSpan)],
imp_mods :: ImportedMods,
-- = ModuleEnv [(ModuleName, Bool, SrcSpan, Bool)],
-- ^ Domain is all directly-imported modules
-- The 'ModuleName' is what the module was imported as, e.g. in
-- @
......
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