Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Alex D
GHC
Commits
93e8ae26
Commit
93e8ae26
authored
Aug 23, 2012
by
dterei
Browse files
Fix :issafe command (#7172).
parent
2b5b178f
Changes
3
Hide whitespace changes
Inline
Side-by-side
compiler/main/GHC.hs
View file @
93e8ae26
...
...
@@ -91,6 +91,7 @@ module GHC (
findModule
,
lookupModule
,
#
ifdef
GHCI
isModuleTrusted
,
moduleTrustReqs
,
setContext
,
getContext
,
getNamesInScope
,
getRdrNamesInScope
,
...
...
@@ -1335,6 +1336,11 @@ isModuleTrusted :: GhcMonad m => Module -> m Bool
isModuleTrusted
m
=
withSession
$
\
hsc_env
->
liftIO
$
hscCheckSafe
hsc_env
m
noSrcSpan
-- | Return if a module is trusted and the pkgs it depends on to be trusted.
moduleTrustReqs
::
GhcMonad
m
=>
Module
->
m
(
Bool
,
[
PackageId
])
moduleTrustReqs
m
=
withSession
$
\
hsc_env
->
liftIO
$
hscGetSafe
hsc_env
m
noSrcSpan
-- | EXPERIMENTAL: DO NOT USE.
--
-- Set the monad GHCi lifts user statements into.
...
...
compiler/main/HscMain.hs
View file @
93e8ae26
...
...
@@ -61,6 +61,7 @@ module HscMain
,
hscTcRcLookupName
,
hscTcRnGetInfo
,
hscCheckSafe
,
hscGetSafe
#
ifdef
GHCI
,
hscIsGHCiMonad
,
hscGetModuleInterface
...
...
@@ -1023,6 +1024,21 @@ hscCheckSafe hsc_env m l = runHsc hsc_env $ do
errs
<-
getWarnings
return
$
isEmptyBag
errs
-- | Return if a module is trusted and the pkgs it depends on to be trusted.
hscGetSafe
::
HscEnv
->
Module
->
SrcSpan
->
IO
(
Bool
,
[
PackageId
])
hscGetSafe
hsc_env
m
l
=
runHsc
hsc_env
$
do
dflags
<-
getDynFlags
(
self
,
pkgs
)
<-
hscCheckSafe'
dflags
m
l
good
<-
isEmptyBag
`
fmap
`
getWarnings
clearWarnings
-- don't want them printed...
let
pkgs'
|
Just
p
<-
self
=
p
:
pkgs
|
otherwise
=
pkgs
return
(
good
,
pkgs'
)
-- | Is a module trusted? If not, throw or log errors depending on the type.
-- Return (regardless of trusted or not) if the trust type requires the modules
-- own package be trusted and a list of other packages required to be trusted
-- (these later ones haven't been checked) but the own package trust has been.
hscCheckSafe'
::
DynFlags
->
Module
->
SrcSpan
->
Hsc
(
Maybe
PackageId
,
[
PackageId
])
hscCheckSafe'
dflags
m
l
=
do
(
tw
,
pkgs
)
<-
isModSafe
m
l
...
...
@@ -1031,10 +1047,6 @@ hscCheckSafe' dflags m l = do
True
|
isHomePkg
m
->
return
(
Nothing
,
pkgs
)
|
otherwise
->
return
(
Just
$
modulePackageId
m
,
pkgs
)
where
-- Is a module trusted? If not, throw or log errors depending on the type.
-- Return (regardless of trusted or not) if the trust type requires the
-- modules own package be trusted and a list of other packages required to
-- be trusted (these later ones haven't been checked)
isModSafe
::
Module
->
SrcSpan
->
Hsc
(
Bool
,
[
PackageId
])
isModSafe
m
l
=
do
iface
<-
lookup'
m
...
...
@@ -1080,6 +1092,8 @@ hscCheckSafe' dflags m l = do
-- trustworthy modules, modules in the home package are trusted but
-- otherwise we check the package trust flag.
packageTrusted
::
SafeHaskellMode
->
Bool
->
Module
->
Bool
packageTrusted
Sf_None
_
_
=
False
-- shouldn't hit these cases
packageTrusted
Sf_Unsafe
_
_
=
False
-- prefer for completeness.
packageTrusted
_
_
_
|
not
(
packageTrustOn
dflags
)
=
True
packageTrusted
Sf_Safe
False
_
=
True
...
...
ghc/InteractiveUI.hs
View file @
93e8ae26
...
...
@@ -33,7 +33,7 @@ import GHC ( LoadHowMuch(..), Target(..), TargetId(..), InteractiveImport(..),
TyThing
(
..
),
Phase
,
BreakIndex
,
Resume
,
SingleStep
,
Ghc
,
handleSourceError
)
import
HsImpExp
import
HscTypes
(
tyThingParent_maybe
,
handleFlagWarnings
,
getSafeMode
,
dep_pkgs
,
hsc_IC
,
import
HscTypes
(
tyThingParent_maybe
,
handleFlagWarnings
,
getSafeMode
,
hsc_IC
,
setInteractivePrintName
)
import
Module
import
Name
...
...
@@ -1487,48 +1487,34 @@ isSafeModule m = do
(
ghcError
$
CmdLineError
$
"can't load interface file for module: "
++
(
GHC
.
moduleNameString
$
GHC
.
moduleName
m
))
let
iface'
=
fromJust
iface
trust
=
showPpr
dflags
$
getSafeMode
$
GHC
.
mi_trust
iface'
pkgT
=
packageTrusted
dflags
m
pkg
=
if
pkgT
then
"trusted"
else
"untrusted"
(
good'
,
bad'
)
=
tallyPkgs
dflags
$
map
fst
$
filter
snd
$
dep_pkgs
$
GHC
.
mi_deps
iface'
(
good
,
bad
)
=
case
GHC
.
mi_trust_pkg
iface'
of
True
|
pkgT
->
(
modulePackageId
m
:
good'
,
bad'
)
True
->
(
good'
,
modulePackageId
m
:
bad'
)
False
->
(
good'
,
bad'
)
(
msafe
,
pkgs
)
<-
GHC
.
moduleTrustReqs
m
let
trust
=
showPpr
dflags
$
getSafeMode
$
GHC
.
mi_trust
$
fromJust
iface
pkg
=
if
packageTrusted
dflags
m
then
"trusted"
else
"untrusted"
(
good
,
bad
)
=
tallyPkgs
dflags
pkgs
-- print info to user...
liftIO
$
putStrLn
$
"Trust type is (Module: "
++
trust
++
", Package: "
++
pkg
++
")"
liftIO
$
putStrLn
$
"Package Trust: "
++
(
if
packageTrustOn
dflags
then
"On"
else
"Off"
)
when
(
packageTrustOn
dflags
&&
not
(
null
good
))
liftIO
$
putStrLn
$
"Package Trust: "
++
(
if
packageTrustOn
dflags
then
"On"
else
"Off"
)
when
(
not
$
null
good
)
(
liftIO
$
putStrLn
$
"Trusted package dependencies (trusted): "
++
(
intercalate
", "
$
map
packageIdString
good
))
case
goodTrust
(
getSafeMode
$
GHC
.
mi_trust
iface'
)
of
True
|
(
null
bad
||
not
(
packageTrustOn
dflags
))
->
liftIO
$
putStrLn
$
mname
++
" is trusted!"
True
->
do
liftIO
$
putStrLn
$
"Trusted package dependencies (untrusted): "
++
(
intercalate
", "
$
map
packageIdString
bad
)
case
msafe
&&
null
bad
of
True
->
liftIO
$
putStrLn
$
mname
++
" is trusted!"
False
->
do
when
(
not
$
null
bad
)
(
liftIO
$
putStrLn
$
"Trusted package dependencies (untrusted): "
++
(
intercalate
", "
$
map
packageIdString
bad
))
liftIO
$
putStrLn
$
mname
++
" is NOT trusted!"
False
->
liftIO
$
putStrLn
$
mname
++
" is NOT trusted!"
where
goodTrust
t
=
t
`
elem
`
[
Sf_Safe
,
Sf_SafeInferred
,
Sf_Trustworthy
]
mname
=
GHC
.
moduleNameString
$
GHC
.
moduleName
m
packageTrusted
dflags
md
|
thisPackage
dflags
==
modulePackageId
md
=
True
|
otherwise
=
trusted
$
getPackageDetails
(
pkgState
dflags
)
(
modulePackageId
md
)
|
otherwise
=
trusted
$
getPackageDetails
(
pkgState
dflags
)
(
modulePackageId
md
)
tallyPkgs
dflags
deps
=
partition
part
deps
tallyPkgs
dflags
deps
|
not
(
packageTrustOn
dflags
)
=
(
[]
,
[]
)
|
otherwise
=
partition
part
deps
where
state
=
pkgState
dflags
part
pkg
=
trusted
$
getPackageDetails
state
pkg
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a 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