module InteractiveEval (
#ifdef GHCI
RunResult(..), Status(..), Resume(..), History(..),
runStmt, parseImportDecl, SingleStep(..),
resume,
abandon, abandonAll,
getResumeContext,
getHistorySpan,
getModBreaks,
getHistoryModule,
back, forward,
setContext, getContext,
availsToGlobalRdrEnv,
getNamesInScope,
getRdrNamesInScope,
moduleIsInterpreted,
getInfo,
exprType,
typeKind,
parseName,
showModule,
isModuleInterpreted,
compileExpr, dynCompileExpr,
Term(..), obtainTermFromId, obtainTermFromVal, reconstructType
#endif
) where
#ifdef GHCI
#include "HsVersions.h"
import HscMain hiding (compileExpr)
import HsSyn (ImportDecl)
import HscTypes
import TcRnDriver
import TcRnMonad (initTc)
import RnNames (gresFromAvails, rnImports)
import InstEnv
import Type
import TcType hiding( typeKind )
import Var
import Id
import Name hiding ( varName )
import NameSet
import RdrName
import PrelNames (pRELUDE)
import VarSet
import VarEnv
import ByteCodeInstr
import Linker
import DynFlags
import Unique
import UniqSupply
import Module
import Panic
import UniqFM
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, partition)
import Control.Monad
import Foreign hiding (unsafePerformIO)
import Foreign.C
import GHC.Exts
import Data.Array
import Exception
import Control.Concurrent
import Data.List (sortBy)
import System.IO
import System.IO.Unsafe
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],
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
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
parseImportDecl :: GhcMonad m => String -> m (ImportDecl RdrName)
parseImportDecl expr = withSession $ \hsc_env -> hscImport hsc_env expr
emptyHistory :: BoundedList History
emptyHistory = nilBL 50
handleRunStatus :: GhcMonad m =>
String-> [Id] -> [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 { resumeStmt = expr, resumeThreadId = tid
, resumeBreakMVar = breakMVar, resumeStatMVar = statusMVar
, resumeBindings = bindings, resumeFinalIds = final_ids
, resumeApStack = apStack, resumeBreakInfo = mb_info
, resumeSpan = span, resumeHistory = toListBL history
, resumeHistoryIx = 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
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] -> [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 =
mask $ \restore ->
let runIt = liftM Complete $ try (restore $ rethrow dflags thing)
in if dopt Opt_GhciSandbox dflags
then do tid <- forkIO $ do res <- runIt
putMVar statusMVar res
withInterruptsSentTo tid $ takeMVar statusMVar
else
runIt
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 UserInterrupt -> 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 = resumeBindings r
ic' = ic { ic_tmp_ids = resume_tmp_ids,
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 { resumeStmt = expr, resumeThreadId = tid
, resumeBreakMVar = breakMVar, resumeStatMVar = statusMVar
, resumeBindings = bindings, resumeFinalIds = final_ids
, resumeApStack = apStack, resumeBreakInfo = info, resumeSpan = span
, resumeHistory = 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 = mkRuntimeUnkTyVar e_name liftedTypeKind
exn_id = Id.mkVanillaGlobal exn_name (mkTyVarTy e_tyvar)
ictxt0 = hsc_IC hsc_env
ictxt1 = extendInteractiveContext ictxt0 [exn_id]
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
pointers = filter (\(id,_) -> isPointer id) vars
isPointer id | PtrRep <- idPrimRep id = True
| otherwise = False
(ids, offsets) = unzip pointers
free_tvs = foldr (unionVarSet . tyVarsOfType . idType)
(tyVarsOfType result_ty) ids
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"
us <- mkSplitUniqSupply 'I'
let (us1, us2) = splitUniqSupply us
tv_subst = newTyVars us1 free_tvs
new_ids = zipWith3 (mkNewId tv_subst) occs filtered_ids (uniqsFromSupply us2)
names = map idName new_ids
let result_name = mkInternalName (getUnique result_fs)
(mkVarOccFS result_fs) span
result_id = Id.mkVanillaGlobal result_name (substTy tv_subst 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 = map idType all_ids
(_,tidy_tys) = tidyOpenTypes emptyTidyEnv id_tys
final_ids = zipWith setIdType all_ids tidy_tys
ictxt0 = hsc_IC hsc_env
ictxt1 = extendInteractiveContext ictxt0 final_ids
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 :: TvSubst -> OccName -> Id -> Unique -> Id
mkNewId tv_subst occ id uniq
= Id.mkVanillaGlobalWithInfo name ty (idInfo id)
where
loc = nameSrcSpan (idName id)
name = mkInternalName uniq occ loc
ty = substTy tv_subst (idType id)
newTyVars :: UniqSupply -> TcTyVarSet -> TvSubst
newTyVars us tvs
= mkTopTvSubst [ (tv, mkTyVarTy (mkRuntimeUnkTyVar name (tyVarKind tv)))
| (tv, uniq) <- varSetElems tvs `zip` uniqsFromSupply us
, let name = setNameUnique (tyVarName tv) uniq ]
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 = isEmptyVarSet . 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
case improveRTTIType hsc_env old_ty new_ty 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 ic' = extendInteractiveContext
(substInteractiveContext ic subst) []
return hsc_env{hsc_IC=ic'}
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, Maybe (ImportDecl RdrName))]
-> m ()
setContext toplev_mods other_mods = do
hsc_env <- getSession
let old_ic = hsc_IC hsc_env
hpt = hsc_HPT hsc_env
(decls,mods) = partition (isJust . snd) other_mods
export_mods = map fst mods
imprt_decls = map noLoc (catMaybes (map snd decls))
export_env <- liftIO $ mkExportEnv hsc_env export_mods
import_env <-
if null imprt_decls then return emptyGlobalRdrEnv else do
let imports = rnImports imprt_decls
this_mod = if null toplev_mods then pRELUDE else head toplev_mods
(_, env, _,_) <-
ioMsgMaybe $ liftIO $ initTc hsc_env HsSrcFile False this_mod imports
return env
toplev_envs <- liftIO $ mapM (mkTopLevEnv hpt) toplev_mods
let all_env = foldr plusGlobalRdrEnv (plusGlobalRdrEnv export_env import_env) toplev_envs
modifySession $ \_ ->
hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplev_mods,
ic_exports = other_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
envs = [ availsToGlobalRdrEnv (moduleName mod) avails
| (Just avails, mod) <- zip mb_name_sets mods ]
; return $! foldr plusGlobalRdrEnv emptyGlobalRdrEnv envs }
availsToGlobalRdrEnv :: ModuleName -> [AvailInfo] -> GlobalRdrEnv
availsToGlobalRdrEnv mod_name avails
= mkGlobalRdrEnv (gresFromAvails imp_prov avails)
where
imp_prov = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}]
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, Maybe (ImportDecl RdrName))])
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 $ orphNamesOfType $ 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
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")
,Nothing):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
mkRuntimeUnkTyVar :: Name -> Kind -> TyVar
mkRuntimeUnkTyVar name kind = mkTcTyVar name kind RuntimeUnk
#endif /* GHCI */