Commit a20cdb93 authored by dterei's avatar dterei

Fix safe imports to work in GHCi.

parent afe7da4f
......@@ -84,9 +84,9 @@ module GHC (
-- * Interactive evaluation
getBindings, getInsts, getPrintUnqual,
findModule,
lookupModule,
findModule, lookupModule,
#ifdef GHCI
isModuleTrusted,
setContext, getContext,
getNamesInScope,
getRdrNamesInScope,
......@@ -1247,26 +1247,32 @@ lookupModule mod_name Nothing = withSession $ \hsc_env -> do
Found _ m -> return m
err -> noModError (hsc_dflags hsc_env) noSrcSpan mod_name err
lookupLoadedHomeModule :: GhcMonad m => ModuleName -> m (Maybe Module)
lookupLoadedHomeModule :: GhcMonad m => ModuleName -> m (Maybe Module)
lookupLoadedHomeModule mod_name = withSession $ \hsc_env ->
case lookupUFM (hsc_HPT hsc_env) mod_name of
Just mod_info -> return (Just (mi_module (hm_iface mod_info)))
_not_a_home_module -> return Nothing
#ifdef GHCI
-- | Check that a module is safe to import (according to Safe Haskell).
--
-- We return True to indicate the import is safe and False otherwise
-- although in the False case an error may be thrown first.
isModuleTrusted :: GhcMonad m => Module -> m Bool
isModuleTrusted m = withSession $ \hsc_env ->
liftIO $ hscCheckSafe hsc_env m noSrcSpan
getHistorySpan :: GhcMonad m => History -> m SrcSpan
getHistorySpan h = withSession $ \hsc_env ->
return$ InteractiveEval.getHistorySpan hsc_env h
return $ InteractiveEval.getHistorySpan hsc_env h
obtainTermFromVal :: GhcMonad m => Int -> Bool -> Type -> a -> m Term
obtainTermFromVal bound force ty a =
withSession $ \hsc_env ->
liftIO $ InteractiveEval.obtainTermFromVal hsc_env bound force ty a
obtainTermFromVal bound force ty a = withSession $ \hsc_env ->
liftIO $ InteractiveEval.obtainTermFromVal hsc_env bound force ty a
obtainTermFromId :: GhcMonad m => Int -> Bool -> Id -> m Term
obtainTermFromId bound force id =
withSession $ \hsc_env ->
liftIO $ InteractiveEval.obtainTermFromId hsc_env bound force id
obtainTermFromId bound force id = withSession $ \hsc_env ->
liftIO $ InteractiveEval.obtainTermFromId hsc_env bound force id
#endif
......
......@@ -206,6 +206,9 @@ instance Monad Hsc where
instance MonadIO Hsc where
liftIO io = Hsc $ \_ w -> do a <- io; return (a, w)
instance Functor Hsc where
fmap f m = m >>= \a -> return $ f a
runHsc :: HscEnv -> Hsc a -> IO a
runHsc hsc_env (Hsc hsc) = do
(a, w) <- hsc hsc_env emptyBag
......@@ -982,30 +985,33 @@ checkSafeImports dflags tcg_env
-- easier interface to work with
checkSafe (_, _, False) = return Nothing
checkSafe (m, l, True ) = hscCheckSafe' dflags m l
checkSafe (m, l, True ) = fst `fmap` hscCheckSafe' dflags m l
-- | Check that a module is safe to import.
--
-- We return a package id if the safe import is OK and a Nothing otherwise
-- with the reason for the failure printed out.
hscCheckSafe :: HscEnv -> Module -> SrcSpan -> IO (Maybe PackageId)
-- We return True to indicate the import is safe and False otherwise
-- although in the False case an exception may be thrown first.
hscCheckSafe :: HscEnv -> Module -> SrcSpan -> IO Bool
hscCheckSafe hsc_env m l = runHsc hsc_env $ do
dflags <- getDynFlags
hscCheckSafe' dflags m l
pkgs <- snd `fmap` hscCheckSafe' dflags m l
when (packageTrustOn dflags) $ checkPkgTrust dflags pkgs
errs <- getWarnings
return $ isEmptyBag errs
hscCheckSafe' :: DynFlags -> Module -> SrcSpan -> Hsc (Maybe PackageId)
hscCheckSafe' :: DynFlags -> Module -> SrcSpan -> Hsc (Maybe PackageId, [PackageId])
hscCheckSafe' dflags m l = do
tw <- isModSafe m l
(tw, pkgs) <- isModSafe m l
case tw of
False -> return Nothing
True | isHomePkg m -> return Nothing
| otherwise -> return $ Just $ modulePackageId m
False -> return (Nothing, pkgs)
True | isHomePkg m -> return (Nothing, pkgs)
| otherwise -> return (Just $ modulePackageId m, pkgs)
where
-- Is a module trusted? Return Nothing if True, or a String if it isn't,
-- containing the reason it isn't. Also return if the module trustworthy
-- (true) or safe (false) so we know if we should check if the package
-- itself is trusted in the future.
isModSafe :: Module -> SrcSpan -> Hsc (Bool)
-- 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
case iface of
......@@ -1022,11 +1028,14 @@ hscCheckSafe' dflags m l = do
safeM = trust `elem` [Sf_SafeInfered, Sf_Safe, Sf_Trustworthy]
-- check package is trusted
safeP = packageTrusted trust trust_own_pkg m
-- pkg trust reqs
pkgRs = map fst $ filter snd $ dep_pkgs $ mi_deps iface'
case (safeM, safeP) of
-- General errors we throw but Safe errors we log
(True, True ) -> return $ trust == Sf_Trustworthy
(True, True ) -> return (trust == Sf_Trustworthy, pkgRs)
(True, False) -> liftIO . throwIO $ pkgTrustErr
(False, _ ) -> logWarnings modTrustErr >> return (trust == Sf_Trustworthy)
(False, _ ) -> logWarnings modTrustErr >>
return (trust == Sf_Trustworthy, pkgRs)
where
pkgTrustErr = mkSrcErr $ unitBag $ mkPlainErrMsg l $ ppr m
......@@ -1058,7 +1067,18 @@ hscCheckSafe' dflags m l = do
let pkgIfaceT = eps_PIT hsc_eps
homePkgT = hsc_HPT hsc_env
iface = lookupIfaceByModule dflags homePkgT pkgIfaceT m
#ifdef GHCI
-- the 'lookupIfaceByModule' method will always fail when calling from GHCi
-- as the compiler hasn't filled in the various module tables
-- so we need to call 'getModuleInterface' to load from disk
iface' <- case iface of
Just _ -> return iface
Nothing -> snd `fmap` (liftIO $ getModuleInterface hsc_env m)
return iface'
#else
return iface
#endif
isHomePkg :: Module -> Bool
isHomePkg m
......
......@@ -1619,12 +1619,23 @@ setContext starred not_starred = do
setGHCContextFromGHCiState
checkAdd :: Bool -> String -> GHCi InteractiveImport
checkAdd star mstr
| star = do m <- wantInterpretedModule mstr
return (IIModule m)
| otherwise = do m <- lookupModule mstr
return (IIDecl (simpleImportDecl (moduleName m)))
checkAdd star mstr = do
dflags <- getDynFlags
case safeLanguageOn dflags of
True | star -> ghcError $ CmdLineError "can't use * imports with Safe Haskell"
True -> do m <- lookupModule mstr
s <- GHC.isModuleTrusted m
case s of
True -> return $ IIDecl (simpleImportDecl $ moduleName m)
False -> ghcError $ CmdLineError $ "can't import " ++ mstr
++ " as it isn't trusted."
False | star -> do m <- wantInterpretedModule mstr
return $ IIModule m
False -> do m <- lookupModule mstr
return $ IIDecl (simpleImportDecl $ moduleName m)
-- | Sets the GHC context from the GHCi state. The GHC context is
-- always set this way, we never modify it incrementally.
......
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