module InteractiveEval (
#ifdef GHCI
RunResult(..), Status(..), Resume(..), History(..),
runStmt, SingleStep(..),
resume,
abandon, abandonAll,
getResumeContext,
getHistorySpan,
getModBreaks,
getHistoryModule,
back, forward,
setContext, getContext,
nameSetToGlobalRdrEnv,
getNamesInScope,
getRdrNamesInScope,
moduleIsInterpreted,
getInfo,
exprType,
typeKind,
parseName,
showModule,
isModuleInterpreted,
compileExpr, dynCompileExpr,
lookupName,
Term(..), obtainTermFromId, obtainTermFromVal, reconstructType,
skolemiseSubst, skolemiseTy
#endif
) where
#ifdef GHCI
#include "HsVersions.h"
import HscMain hiding (compileExpr)
import HscTypes
import TcRnDriver
import Type hiding (typeKind)
import TcType hiding (typeKind)
import InstEnv
import Var
import Id
import Name hiding ( varName )
import NameSet
import RdrName
import VarSet
import VarEnv
import ByteCodeInstr
import Linker
import DynFlags
import Unique
import UniqSupply
import Module
import Panic
import LazyUniqFM
import Maybes
import ErrUtils
import Util
import SrcLoc
import BreakArray
import RtClosureInspect
import BasicTypes
import Outputable
import FastString
import MonadUtils
import System.Directory
import Data.Dynamic
import Data.List (find)
import Control.Monad
import Foreign
import Foreign.C
import GHC.Exts
import Data.Array
import Exception
import Control.Concurrent
import Data.List (sortBy)
import System.IO
data RunResult
= RunOk [Name]
| RunFailed
| RunException SomeException
| RunBreak ThreadId [Name] (Maybe BreakInfo)
data Status
= Break Bool HValue BreakInfo ThreadId
| Complete (Either SomeException [HValue])
data Resume
= Resume {
resumeStmt :: String,
resumeThreadId :: ThreadId,
resumeBreakMVar :: MVar (),
resumeStatMVar :: MVar Status,
resumeBindings :: ([Id], TyVarSet),
resumeFinalIds :: [Id],
resumeApStack :: HValue,
resumeBreakInfo :: Maybe BreakInfo,
resumeSpan :: SrcSpan,
resumeHistory :: [History],
resumeHistoryIx :: Int
}
getResumeContext :: GhcMonad m => m [Resume]
getResumeContext = withSession (return . ic_resume . hsc_IC)
data SingleStep
= RunToCompletion
| SingleStep
| RunAndLogSteps
isStep :: SingleStep -> Bool
isStep RunToCompletion = False
isStep _ = True
data History
= History {
historyApStack :: HValue,
historyBreakInfo :: BreakInfo,
historyEnclosingDecl :: Id
}
mkHistory :: HscEnv -> HValue -> BreakInfo -> History
mkHistory hsc_env hval bi = let
h = History hval bi decl
decl = findEnclosingDecl hsc_env (getHistoryModule h)
(getHistorySpan hsc_env h)
in h
getHistoryModule :: History -> Module
getHistoryModule = breakInfo_module . historyBreakInfo
getHistorySpan :: HscEnv -> History -> SrcSpan
getHistorySpan hsc_env hist =
let inf = historyBreakInfo hist
num = breakInfo_number inf
in case lookupUFM (hsc_HPT hsc_env) (moduleName (breakInfo_module inf)) of
Just hmi -> modBreaks_locs (getModBreaks hmi) ! num
_ -> panic "getHistorySpan"
getModBreaks :: HomeModInfo -> ModBreaks
getModBreaks hmi
| Just linkable <- hm_linkable hmi,
[BCOs _ modBreaks] <- linkableUnlinked linkable
= modBreaks
| otherwise
= emptyModBreaks
findEnclosingDecl :: HscEnv -> Module -> SrcSpan -> Id
findEnclosingDecl hsc_env mod span =
case lookupUFM (hsc_HPT hsc_env) (moduleName mod) of
Nothing -> panic "findEnclosingDecl"
Just hmi -> let
globals = typeEnvIds (md_types (hm_details hmi))
Just decl =
find (\id -> let n = idName id in
nameSrcSpan n < span && isExternalName n)
(reverse$ sortBy (compare `on` (nameSrcSpan.idName))
globals)
in decl
runStmt :: GhcMonad m => String -> SingleStep -> m RunResult
runStmt expr step =
do
hsc_env <- getSession
breakMVar <- liftIO $ newEmptyMVar
statusMVar <- liftIO $ newEmptyMVar
let dflags' = dopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds
hsc_env' = hsc_env{ hsc_dflags = dflags' }
r <- hscStmt hsc_env' expr
case r of
Nothing -> return RunFailed
Just (ids, hval) -> do
warns <- getWarnings
liftIO $ printBagOfWarnings dflags' warns
clearWarnings
status <-
withVirtualCWD $
withBreakAction (isStep step) dflags' breakMVar statusMVar $ do
let thing_to_run = unsafeCoerce# hval :: IO [HValue]
liftIO $ sandboxIO dflags' statusMVar thing_to_run
let ic = hsc_IC hsc_env
bindings = (ic_tmp_ids ic, ic_tyvars ic)
case step of
RunAndLogSteps ->
traceRunStatus expr bindings ids
breakMVar statusMVar status emptyHistory
_other ->
handleRunStatus expr bindings ids
breakMVar statusMVar status emptyHistory
withVirtualCWD :: GhcMonad m => m a -> m a
withVirtualCWD m = do
hsc_env <- getSession
let ic = hsc_IC hsc_env
let set_cwd = do
dir <- liftIO $ getCurrentDirectory
case ic_cwd ic of
Just dir -> liftIO $ setCurrentDirectory dir
Nothing -> return ()
return dir
reset_cwd orig_dir = do
virt_dir <- liftIO $ getCurrentDirectory
hsc_env <- getSession
let old_IC = hsc_IC hsc_env
setSession hsc_env{ hsc_IC = old_IC{ ic_cwd = Just virt_dir } }
liftIO $ setCurrentDirectory orig_dir
gbracket set_cwd reset_cwd $ \_ -> m
emptyHistory :: BoundedList History
emptyHistory = nilBL 50
handleRunStatus :: GhcMonad m =>
String-> ([Id], TyVarSet) -> [Id]
-> MVar () -> MVar Status -> Status -> BoundedList History
-> m RunResult
handleRunStatus expr bindings final_ids breakMVar statusMVar status
history =
case status of
(Break is_exception apStack info tid) -> do
hsc_env <- getSession
let mb_info | is_exception = Nothing
| otherwise = Just info
(hsc_env1, names, span) <- liftIO $ bindLocalsAtBreakpoint hsc_env apStack
mb_info
let
resume = Resume expr tid breakMVar statusMVar
bindings final_ids apStack mb_info span
(toListBL history) 0
hsc_env2 = pushResume hsc_env1 resume
modifySession (\_ -> hsc_env2)
return (RunBreak tid names mb_info)
(Complete either_hvals) ->
case either_hvals of
Left e -> return (RunException e)
Right hvals -> do
hsc_env <- getSession
let final_ic = extendInteractiveContext (hsc_IC hsc_env)
final_ids emptyVarSet
final_names = map idName final_ids
liftIO $ Linker.extendLinkEnv (zip final_names hvals)
hsc_env' <- liftIO $ rttiEnvironment hsc_env{hsc_IC=final_ic}
modifySession (\_ -> hsc_env')
return (RunOk final_names)
traceRunStatus :: GhcMonad m =>
String -> ([Id], TyVarSet) -> [Id]
-> MVar () -> MVar Status -> Status -> BoundedList History
-> m RunResult
traceRunStatus expr bindings final_ids
breakMVar statusMVar status history = do
hsc_env <- getSession
case status of
(Break is_exception apStack info tid) | not is_exception -> do
b <- liftIO $ isBreakEnabled hsc_env info
if b
then handle_normally
else do
let history' = mkHistory hsc_env apStack info `consBL` history
_ <- liftIO $ evaluate history'
status <-
withBreakAction True (hsc_dflags hsc_env)
breakMVar statusMVar $ do
liftIO $ withInterruptsSentTo tid $ do
putMVar breakMVar ()
takeMVar statusMVar
traceRunStatus expr bindings final_ids
breakMVar statusMVar status history'
_other ->
handle_normally
where
handle_normally = handleRunStatus expr bindings final_ids
breakMVar statusMVar status history
isBreakEnabled :: HscEnv -> BreakInfo -> IO Bool
isBreakEnabled hsc_env inf =
case lookupUFM (hsc_HPT hsc_env) (moduleName (breakInfo_module inf)) of
Just hmi -> do
w <- getBreak (modBreaks_flags (getModBreaks hmi))
(breakInfo_number inf)
case w of Just n -> return (n /= 0); _other -> return False
_ ->
return False
foreign import ccall "&rts_stop_next_breakpoint" stepFlag :: Ptr CInt
foreign import ccall "&rts_stop_on_exception" exceptionFlag :: Ptr CInt
setStepFlag :: IO ()
setStepFlag = poke stepFlag 1
resetStepFlag :: IO ()
resetStepFlag = poke stepFlag 0
foreign import ccall "&rts_breakpoint_io_action"
breakPointIOAction :: Ptr (StablePtr (Bool -> BreakInfo -> HValue -> IO ()))
sandboxIO :: DynFlags -> MVar Status -> IO [HValue] -> IO Status
sandboxIO dflags statusMVar thing =
block $ do
id <- forkIO $ do res <- Exception.try (unblock $ rethrow dflags thing)
putMVar statusMVar (Complete res)
withInterruptsSentTo id $ takeMVar statusMVar
rethrow :: DynFlags -> IO a -> IO a
rethrow dflags io = Exception.catch io $ \se -> do
if dopt Opt_BreakOnError dflags &&
not (dopt Opt_BreakOnException dflags)
then poke exceptionFlag 1
else case fromException se of
Just Interrupted -> return ()
_ -> poke exceptionFlag 0
Exception.throwIO se
withInterruptsSentTo :: ThreadId -> IO r -> IO r
withInterruptsSentTo thread get_result = do
bracket (modifyMVar_ interruptTargetThread (return . (thread:)))
(\_ -> modifyMVar_ interruptTargetThread (\tl -> return $! tail tl))
(\_ -> get_result)
withBreakAction :: (ExceptionMonad m, MonadIO m) =>
Bool -> DynFlags -> MVar () -> MVar Status -> m a -> m a
withBreakAction step dflags breakMVar statusMVar act
= gbracket (liftIO setBreakAction) (liftIO . resetBreakAction) (\_ -> act)
where
setBreakAction = do
stablePtr <- newStablePtr onBreak
poke breakPointIOAction stablePtr
when (dopt Opt_BreakOnException dflags) $ poke exceptionFlag 1
when step $ setStepFlag
return stablePtr
onBreak is_exception info apStack = do
tid <- myThreadId
putMVar statusMVar (Break is_exception apStack info tid)
takeMVar breakMVar
resetBreakAction stablePtr = do
poke breakPointIOAction noBreakStablePtr
poke exceptionFlag 0
resetStepFlag
freeStablePtr stablePtr
noBreakStablePtr :: StablePtr (Bool -> BreakInfo -> HValue -> IO ())
noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction
noBreakAction :: Bool -> BreakInfo -> HValue -> IO ()
noBreakAction False _ _ = putStrLn "*** Ignoring breakpoint"
noBreakAction True _ _ = return ()
resume :: GhcMonad m => (SrcSpan->Bool) -> SingleStep -> m RunResult
resume canLogSpan step
= do
hsc_env <- getSession
let ic = hsc_IC hsc_env
resume = ic_resume ic
case resume of
[] -> ghcError (ProgramError "not stopped at a breakpoint")
(r:rs) -> do
let (resume_tmp_ids, resume_tyvars) = resumeBindings r
ic' = ic { ic_tmp_ids = resume_tmp_ids,
ic_tyvars = resume_tyvars,
ic_resume = rs }
modifySession (\_ -> hsc_env{ hsc_IC = ic' })
let new_names = map idName (filter (`notElem` resume_tmp_ids)
(ic_tmp_ids ic))
liftIO $ Linker.deleteFromLinkEnv new_names
when (isStep step) $ liftIO setStepFlag
case r of
Resume expr tid breakMVar statusMVar bindings
final_ids apStack info span hist _ -> do
withVirtualCWD $ do
withBreakAction (isStep step) (hsc_dflags hsc_env)
breakMVar statusMVar $ do
status <- liftIO $ withInterruptsSentTo tid $ do
putMVar breakMVar ()
takeMVar statusMVar
let prevHistoryLst = fromListBL 50 hist
hist' = case info of
Nothing -> prevHistoryLst
Just i
| not $canLogSpan span -> prevHistoryLst
| otherwise -> mkHistory hsc_env apStack i `consBL`
fromListBL 50 hist
case step of
RunAndLogSteps ->
traceRunStatus expr bindings final_ids
breakMVar statusMVar status hist'
_other ->
handleRunStatus expr bindings final_ids
breakMVar statusMVar status hist'
back :: GhcMonad m => m ([Name], Int, SrcSpan)
back = moveHist (+1)
forward :: GhcMonad m => m ([Name], Int, SrcSpan)
forward = moveHist (subtract 1)
moveHist :: GhcMonad m => (Int -> Int) -> m ([Name], Int, SrcSpan)
moveHist fn = do
hsc_env <- getSession
case ic_resume (hsc_IC hsc_env) of
[] -> ghcError (ProgramError "not stopped at a breakpoint")
(r:rs) -> do
let ix = resumeHistoryIx r
history = resumeHistory r
new_ix = fn ix
when (new_ix > length history) $
ghcError (ProgramError "no more logged breakpoints")
when (new_ix < 0) $
ghcError (ProgramError "already at the beginning of the history")
let
update_ic apStack mb_info = do
(hsc_env1, names, span) <- liftIO $ bindLocalsAtBreakpoint hsc_env
apStack mb_info
let ic = hsc_IC hsc_env1
r' = r { resumeHistoryIx = new_ix }
ic' = ic { ic_resume = r':rs }
modifySession (\_ -> hsc_env1{ hsc_IC = ic' })
return (names, new_ix, span)
if new_ix == 0
then case r of
Resume { resumeApStack = apStack,
resumeBreakInfo = mb_info } ->
update_ic apStack mb_info
else case history !! (new_ix 1) of
History apStack info _ ->
update_ic apStack (Just info)
result_fs :: FastString
result_fs = fsLit "_result"
bindLocalsAtBreakpoint
:: HscEnv
-> HValue
-> Maybe BreakInfo
-> IO (HscEnv, [Name], SrcSpan)
bindLocalsAtBreakpoint hsc_env apStack Nothing = do
let exn_fs = fsLit "_exception"
exn_name = mkInternalName (getUnique exn_fs) (mkVarOccFS exn_fs) span
e_fs = fsLit "e"
e_name = mkInternalName (getUnique e_fs) (mkTyVarOccFS e_fs) span
e_tyvar = mkTcTyVar e_name liftedTypeKind (SkolemTv RuntimeUnkSkol)
exn_id = Id.mkVanillaGlobal exn_name (mkTyVarTy e_tyvar)
new_tyvars = unitVarSet e_tyvar
ictxt0 = hsc_IC hsc_env
ictxt1 = extendInteractiveContext ictxt0 [exn_id] new_tyvars
span = mkGeneralSrcSpan (fsLit "<exception thrown>")
Linker.extendLinkEnv [(exn_name, unsafeCoerce# apStack)]
return (hsc_env{ hsc_IC = ictxt1 }, [exn_name], span)
bindLocalsAtBreakpoint hsc_env apStack (Just info) = do
let
mod_name = moduleName (breakInfo_module info)
hmi = expectJust "bindLocalsAtBreakpoint" $
lookupUFM (hsc_HPT hsc_env) mod_name
breaks = getModBreaks hmi
index = breakInfo_number info
vars = breakInfo_vars info
result_ty = breakInfo_resty info
occs = modBreaks_vars breaks ! index
span = modBreaks_locs breaks ! index
let pointers = filter (\(id,_) -> isPointer id) vars
isPointer id | PtrRep <- idPrimRep id = True
| otherwise = False
let (ids, offsets) = unzip pointers
mb_hValues <- mapM (getIdValFromApStack apStack) (map fromIntegral offsets)
let filtered_ids = [ id | (id, Just _hv) <- zip ids mb_hValues ]
when (any isNothing mb_hValues) $
debugTraceMsg (hsc_dflags hsc_env) 1 $
text "Warning: _result has been evaluated, some bindings have been lost"
new_ids <- zipWithM mkNewId occs filtered_ids
let names = map idName new_ids
let result_name = mkInternalName (getUnique result_fs)
(mkVarOccFS result_fs) span
result_id = Id.mkVanillaGlobal result_name result_ty
let result_ok = isPointer result_id
&& not (isUnboxedTupleType (idType result_id))
all_ids | result_ok = result_id : new_ids
| otherwise = new_ids
(id_tys, tyvarss) = mapAndUnzip (skolemiseTy.idType) all_ids
(_,tidy_tys) = tidyOpenTypes emptyTidyEnv id_tys
new_tyvars = unionVarSets tyvarss
final_ids = zipWith setIdType all_ids tidy_tys
ictxt0 = hsc_IC hsc_env
ictxt1 = extendInteractiveContext ictxt0 final_ids new_tyvars
Linker.extendLinkEnv [ (name,hval) | (name, Just hval) <- zip names mb_hValues ]
when result_ok $ Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)]
hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 }
return (hsc_env1, if result_ok then result_name:names else names, span)
where
mkNewId :: OccName -> Id -> IO Id
mkNewId occ id = do
us <- mkSplitUniqSupply 'I'
let
uniq = uniqFromSupply us
loc = nameSrcSpan (idName id)
name = mkInternalName uniq occ loc
ty = idType id
new_id = Id.mkVanillaGlobalWithInfo name ty (idInfo id)
return new_id
rttiEnvironment :: HscEnv -> IO HscEnv
rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do
let InteractiveContext{ic_tmp_ids=tmp_ids} = ic
incompletelyTypedIds =
[id | id <- tmp_ids
, not $ noSkolems id
, (occNameFS.nameOccName.idName) id /= result_fs]
hsc_env' <- foldM improveTypes hsc_env (map idName incompletelyTypedIds)
return hsc_env'
where
noSkolems = null . filter isSkolemTyVar . varSetElems . tyVarsOfType . idType
improveTypes hsc_env@HscEnv{hsc_IC=ic} name = do
let InteractiveContext{ic_tmp_ids=tmp_ids} = ic
Just id = find (\i -> idName i == name) tmp_ids
if noSkolems id
then return hsc_env
else do
mb_new_ty <- reconstructType hsc_env 10 id
let old_ty = idType id
case mb_new_ty of
Nothing -> return hsc_env
Just new_ty -> do
mb_subst <- improveRTTIType hsc_env old_ty new_ty
case mb_subst of
Nothing -> return $
WARN(True, text (":print failed to calculate the "
++ "improvement for a type")) hsc_env
Just subst -> do
when (dopt Opt_D_dump_rtti (hsc_dflags hsc_env)) $
printForUser stderr alwaysQualify $
fsep [text "RTTI Improvement for", ppr id, equals, ppr subst]
let (subst', skols) = skolemiseSubst subst
ic' = extendInteractiveContext
(substInteractiveContext ic subst') [] skols
return hsc_env{hsc_IC=ic'}
skolemiseSubst :: TvSubst -> (TvSubst, TyVarSet)
skolemiseSubst subst = let
varenv = getTvSubstEnv subst
all_together = mapVarEnv skolemiseTy varenv
(varenv', skol_vars) = ( mapVarEnv fst all_together
, map snd (varEnvElts all_together))
in (subst `setTvSubstEnv` varenv', unionVarSets skol_vars)
skolemiseTy :: Type -> (Type, TyVarSet)
skolemiseTy ty = (substTy subst ty, mkVarSet new_tyvars)
where env = mkVarEnv (zip tyvars new_tyvar_tys)
subst = mkTvSubst emptyInScopeSet env
tyvars = varSetElems (tyVarsOfType ty)
new_tyvars = map skolemiseTyVar tyvars
new_tyvar_tys = map mkTyVarTy new_tyvars
skolemiseTyVar :: TyVar -> TyVar
skolemiseTyVar tyvar = mkTcTyVar (tyVarName tyvar) (tyVarKind tyvar)
(SkolemTv RuntimeUnkSkol)
getIdValFromApStack :: HValue -> Int -> IO (Maybe HValue)
getIdValFromApStack apStack (I# stackDepth) = do
case getApStackVal# apStack (stackDepth +# 1#) of
(# ok, result #) ->
case ok of
0# -> return Nothing
_ -> return (Just (unsafeCoerce# result))
pushResume :: HscEnv -> Resume -> HscEnv
pushResume hsc_env resume = hsc_env { hsc_IC = ictxt1 }
where
ictxt0 = hsc_IC hsc_env
ictxt1 = ictxt0 { ic_resume = resume : ic_resume ictxt0 }
abandon :: GhcMonad m => m Bool
abandon = do
hsc_env <- getSession
let ic = hsc_IC hsc_env
resume = ic_resume ic
case resume of
[] -> return False
r:rs -> do
modifySession $ \_ -> hsc_env{ hsc_IC = ic { ic_resume = rs } }
liftIO $ abandon_ r
return True
abandonAll :: GhcMonad m => m Bool
abandonAll = do
hsc_env <- getSession
let ic = hsc_IC hsc_env
resume = ic_resume ic
case resume of
[] -> return False
rs -> do
modifySession $ \_ -> hsc_env{ hsc_IC = ic { ic_resume = [] } }
liftIO $ mapM_ abandon_ rs
return True
abandon_ :: Resume -> IO ()
abandon_ r = do
killThread (resumeThreadId r)
putMVar (resumeBreakMVar r) ()
data BoundedList a = BL
!Int
!Int
[a]
[a]
nilBL :: Int -> BoundedList a
nilBL bound = BL 0 bound [] []
consBL :: a -> BoundedList a -> BoundedList a
consBL a (BL len bound left right)
| len < bound = BL (len+1) bound (a:left) right
| null right = BL len bound [a] $! tail (reverse left)
| otherwise = BL len bound (a:left) $! tail right
toListBL :: BoundedList a -> [a]
toListBL (BL _ _ left right) = left ++ reverse right
fromListBL :: Int -> [a] -> BoundedList a
fromListBL bound l = BL (length l) bound l []
setContext :: GhcMonad m =>
[Module]
-> [Module]
-> m ()
setContext toplev_mods export_mods = do
hsc_env <- getSession
let old_ic = hsc_IC hsc_env
hpt = hsc_HPT hsc_env
export_env <- liftIO $ mkExportEnv hsc_env export_mods
toplev_envs <- liftIO $ mapM (mkTopLevEnv hpt) toplev_mods
let all_env = foldr plusGlobalRdrEnv export_env toplev_envs
modifySession $ \_ ->
hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplev_mods,
ic_exports = export_mods,
ic_rn_gbl_env = all_env }}
mkExportEnv :: HscEnv -> [Module] -> IO GlobalRdrEnv
mkExportEnv hsc_env mods = do
stuff <- mapM (getModuleExports hsc_env) mods
let
(_msgs, mb_name_sets) = unzip stuff
gres = [ nameSetToGlobalRdrEnv (availsToNameSet avails) (moduleName mod)
| (Just avails, mod) <- zip mb_name_sets mods ]
return $! foldr plusGlobalRdrEnv emptyGlobalRdrEnv gres
nameSetToGlobalRdrEnv :: NameSet -> ModuleName -> GlobalRdrEnv
nameSetToGlobalRdrEnv names mod =
mkGlobalRdrEnv [ GRE { gre_name = name, gre_par = NoParent, gre_prov = vanillaProv mod }
| name <- nameSetToList names ]
vanillaProv :: ModuleName -> Provenance
vanillaProv mod_name = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}]
where
decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name,
is_qual = False,
is_dloc = srcLocSpan interactiveSrcLoc }
mkTopLevEnv :: HomePackageTable -> Module -> IO GlobalRdrEnv
mkTopLevEnv hpt modl
= case lookupUFM hpt (moduleName modl) of
Nothing -> ghcError (ProgramError ("mkTopLevEnv: not a home module " ++
showSDoc (ppr modl)))
Just details ->
case mi_globals (hm_iface details) of
Nothing ->
ghcError (ProgramError ("mkTopLevEnv: not interpreted "
++ showSDoc (ppr modl)))
Just env -> return env
getContext :: GhcMonad m => m ([Module],[Module])
getContext = withSession $ \HscEnv{ hsc_IC=ic } ->
return (ic_toplev_scope ic, ic_exports ic)
moduleIsInterpreted :: GhcMonad m => Module -> m Bool
moduleIsInterpreted modl = withSession $ \h ->
if modulePackageId modl /= thisPackage (hsc_dflags h)
then return False
else case lookupUFM (hsc_HPT h) (moduleName modl) of
Just details -> return (isJust (mi_globals (hm_iface details)))
_not_a_home_module -> return False
getInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[Instance]))
getInfo name
= withSession $ \hsc_env ->
do mb_stuff <- ioMsg $ tcRnGetInfo hsc_env name
case mb_stuff of
Nothing -> return Nothing
Just (thing, fixity, ispecs) -> do
let rdr_env = ic_rn_gbl_env (hsc_IC hsc_env)
return (Just (thing, fixity, filter (plausible rdr_env) ispecs))
where
plausible rdr_env ispec
= all ok $ nameSetToList $ tyClsNamesOfType $ idType $ instanceDFunId ispec
where
ok n | n == name = True
| isBuiltInSyntax n = True
| isExternalName n = any ((== n) . gre_name)
(lookupGRE_Name rdr_env n)
| otherwise = True
getNamesInScope :: GhcMonad m => m [Name]
getNamesInScope = withSession $ \hsc_env -> do
return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env))))
getRdrNamesInScope :: GhcMonad m => m [RdrName]
getRdrNamesInScope = withSession $ \hsc_env -> do
let
ic = hsc_IC hsc_env
gbl_rdrenv = ic_rn_gbl_env ic
ids = ic_tmp_ids ic
gbl_names = concat (map greToRdrNames (globalRdrEnvElts gbl_rdrenv))
lcl_names = map (mkRdrUnqual.nameOccName.idName) ids
return (gbl_names ++ lcl_names)
greToRdrNames :: GlobalRdrElt -> [RdrName]
greToRdrNames GRE{ gre_name = name, gre_prov = prov }
= case prov of
LocalDef -> [unqual]
Imported specs -> concat (map do_spec (map is_decl specs))
where
occ = nameOccName name
unqual = Unqual occ
do_spec decl_spec
| is_qual decl_spec = [qual]
| otherwise = [unqual,qual]
where qual = Qual (is_as decl_spec) occ
parseName :: GhcMonad m => String -> m [Name]
parseName str = withSession $ \hsc_env -> do
(L _ rdr_name) <- hscParseIdentifier (hsc_dflags hsc_env) str
ioMsgMaybe $ tcRnLookupRdrName hsc_env rdr_name
lookupName :: GhcMonad m => Name -> m (Maybe TyThing)
lookupName name = withSession $ \hsc_env -> do
mb_tything <- ioMsg $ tcRnLookupName hsc_env name
return mb_tything
exprType :: GhcMonad m => String -> m Type
exprType expr = withSession $ \hsc_env -> do
ty <- hscTcExpr hsc_env expr
return $ tidyType emptyTidyEnv ty
typeKind :: GhcMonad m => String -> m Kind
typeKind str = withSession $ \hsc_env -> do
hscKcType hsc_env str
compileExpr :: GhcMonad m => String -> m HValue
compileExpr expr = withSession $ \hsc_env -> do
Just (ids, hval) <- hscStmt hsc_env ("let __cmCompileExpr = "++expr)
hvals <- liftIO (unsafeCoerce# hval :: IO [HValue])
case (ids,hvals) of
([_],[hv]) -> return hv
_ -> panic "compileExpr"
dynCompileExpr :: GhcMonad m => String -> m Dynamic
dynCompileExpr expr = do
(full,exports) <- getContext
setContext full $
(mkModule
(stringToPackageId "base") (mkModuleName "Data.Dynamic")
):exports
let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")"
Just (ids, hvals) <- withSession (flip hscStmt stmt)
setContext full exports
vals <- liftIO (unsafeCoerce# hvals :: IO [Dynamic])
case (ids,vals) of
(_:[], v:[]) -> return v
_ -> panic "dynCompileExpr"
showModule :: GhcMonad m => ModSummary -> m String
showModule mod_summary =
withSession $ \hsc_env -> do
interpreted <- isModuleInterpreted mod_summary
return (showModMsg (hscTarget(hsc_dflags hsc_env)) interpreted mod_summary)
isModuleInterpreted :: GhcMonad m => ModSummary -> m Bool
isModuleInterpreted mod_summary = withSession $ \hsc_env ->
case lookupUFM (hsc_HPT hsc_env) (ms_mod_name mod_summary) of
Nothing -> panic "missing linkable"
Just mod_info -> return (not obj_linkable)
where
obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info))
obtainTermFromVal :: HscEnv -> Int -> Bool -> Type -> a -> IO Term
obtainTermFromVal hsc_env bound force ty x =
cvObtainTerm hsc_env bound force ty (unsafeCoerce# x)
obtainTermFromId :: HscEnv -> Int -> Bool -> Id -> IO Term
obtainTermFromId hsc_env bound force id = do
hv <- Linker.getHValue hsc_env (varName id)
cvObtainTerm hsc_env bound force (idType id) hv
reconstructType :: HscEnv -> Int -> Id -> IO (Maybe Type)
reconstructType hsc_env bound id = do
hv <- Linker.getHValue hsc_env (varName id)
cvReconstructType hsc_env bound (idType id) hv
#endif /* GHCI */