1 -- -----------------------------------------------------------------------------
3 -- (c) The University of Glasgow, 2005-2007
5 -- Running statements interactively
7 -- -----------------------------------------------------------------------------
9 module InteractiveEval (
11 RunResult(..), Status(..), Resume(..), History(..),
12 runStmt, SingleStep(..),
18 setContext, getContext,
19 nameSetToGlobalRdrEnv,
29 compileExpr, dynCompileExpr,
31 obtainTerm, obtainTerm1, reconstructType,
32 skolemiseSubst, skolemiseTy
38 #include "HsVersions.h"
40 import HscMain hiding (compileExpr)
43 import Type hiding (typeKind)
44 import TcType hiding (typeKind)
46 import Var hiding (setIdType)
49 import Name hiding ( varName )
66 import RtClosureInspect
77 import Control.Exception as Exception
78 import Control.Concurrent
80 import Foreign.StablePtr
82 -- -----------------------------------------------------------------------------
83 -- running a statement interactively
86 = RunOk [Name] -- ^ names bound by this evaluation
87 | RunFailed -- ^ statement failed compilation
88 | RunException Exception -- ^ statement raised an exception
89 | RunBreak ThreadId [Name] (Maybe BreakInfo)
92 = Break Bool HValue BreakInfo ThreadId
93 -- ^ the computation hit a breakpoint (Bool <=> was an exception)
94 | Complete (Either Exception [HValue])
95 -- ^ the computation completed with either an exception or a value
99 resumeStmt :: String, -- the original statement
100 resumeThreadId :: ThreadId, -- thread running the computation
101 resumeBreakMVar :: MVar (),
102 resumeStatMVar :: MVar Status,
103 resumeBindings :: ([Id], TyVarSet),
104 resumeFinalIds :: [Id], -- [Id] to bind on completion
105 resumeApStack :: HValue, -- The object from which we can get
106 -- value of the free variables.
107 resumeBreakInfo :: Maybe BreakInfo,
108 -- the breakpoint we stopped at
109 -- (Nothing <=> exception)
110 resumeSpan :: SrcSpan, -- just a cache, otherwise it's a pain
111 -- to fetch the ModDetails & ModBreaks
113 resumeHistory :: [History],
114 resumeHistoryIx :: Int -- 0 <==> at the top of the history
117 getResumeContext :: Session -> IO [Resume]
118 getResumeContext s = withSession s (return . ic_resume . hsc_IC)
125 isStep RunToCompletion = False
130 historyApStack :: HValue,
131 historyBreakInfo :: BreakInfo
134 getHistorySpan :: Session -> History -> IO SrcSpan
135 getHistorySpan s hist = withSession s $ \hsc_env -> do
136 let inf = historyBreakInfo hist
137 num = breakInfo_number inf
138 case lookupUFM (hsc_HPT hsc_env) (moduleName (breakInfo_module inf)) of
139 Just hmi -> return (modBreaks_locs (md_modBreaks (hm_details hmi)) ! num)
140 _ -> panic "getHistorySpan"
142 -- | Run a statement in the current interactive context. Statement
143 -- may bind multple values.
144 runStmt :: Session -> String -> SingleStep -> IO RunResult
145 runStmt (Session ref) expr step
147 hsc_env <- readIORef ref
149 breakMVar <- newEmptyMVar -- wait on this when we hit a breakpoint
150 statusMVar <- newEmptyMVar -- wait on this when a computation is running
152 -- Turn off -fwarn-unused-bindings when running a statement, to hide
153 -- warnings about the implicit bindings we introduce.
154 let dflags' = dopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds
155 hsc_env' = hsc_env{ hsc_dflags = dflags' }
157 maybe_stuff <- hscStmt hsc_env' expr
160 Nothing -> return RunFailed
161 Just (ids, hval) -> do
163 withBreakAction (isStep step) dflags' breakMVar statusMVar $ do
165 let thing_to_run = unsafeCoerce# hval :: IO [HValue]
166 status <- sandboxIO statusMVar thing_to_run
168 let ic = hsc_IC hsc_env
169 bindings = (ic_tmp_ids ic, ic_tyvars ic)
173 traceRunStatus expr ref bindings ids
174 breakMVar statusMVar status emptyHistory
176 handleRunStatus expr ref bindings ids
177 breakMVar statusMVar status emptyHistory
180 emptyHistory = nilBL 50 -- keep a log of length 50
182 handleRunStatus expr ref bindings final_ids breakMVar statusMVar status
185 -- did we hit a breakpoint or did we complete?
186 (Break is_exception apStack info tid) -> do
187 hsc_env <- readIORef ref
188 let mb_info | is_exception = Nothing
189 | otherwise = Just info
190 (hsc_env1, names, span) <- bindLocalsAtBreakpoint hsc_env
193 resume = Resume expr tid breakMVar statusMVar
194 bindings final_ids apStack mb_info span
196 hsc_env2 = pushResume hsc_env1 resume
198 writeIORef ref hsc_env2
199 return (RunBreak tid names mb_info)
200 (Complete either_hvals) ->
202 Left e -> return (RunException e)
204 hsc_env <- readIORef ref
205 let final_ic = extendInteractiveContext (hsc_IC hsc_env)
206 final_ids emptyVarSet
207 -- the bound Ids never have any free TyVars
208 final_names = map idName final_ids
209 Linker.extendLinkEnv (zip final_names hvals)
210 hsc_env' <- rttiEnvironment hsc_env{hsc_IC=final_ic}
211 writeIORef ref hsc_env'
212 return (RunOk final_names)
215 traceRunStatus expr ref bindings final_ids
216 breakMVar statusMVar status history = do
217 hsc_env <- readIORef ref
219 -- when tracing, if we hit a breakpoint that is not explicitly
220 -- enabled, then we just log the event in the history and continue.
221 (Break is_exception apStack info tid) | not is_exception -> do
222 b <- isBreakEnabled hsc_env info
226 let history' = consBL (History apStack info) history
227 -- probably better make history strict here, otherwise
228 -- our BoundedList will be pointless.
230 status <- withBreakAction True (hsc_dflags hsc_env)
231 breakMVar statusMVar $ do
233 (do putMVar breakMVar () -- awaken the stopped thread
235 (takeMVar statusMVar) -- and wait for the result
236 traceRunStatus expr ref bindings final_ids
237 breakMVar statusMVar status history'
241 handle_normally = handleRunStatus expr ref bindings final_ids
242 breakMVar statusMVar status history
245 isBreakEnabled :: HscEnv -> BreakInfo -> IO Bool
246 isBreakEnabled hsc_env inf =
247 case lookupUFM (hsc_HPT hsc_env) (moduleName (breakInfo_module inf)) of
249 w <- getBreak (modBreaks_flags (md_modBreaks (hm_details hmi)))
250 (breakInfo_number inf)
251 case w of Just n -> return (n /= 0); _other -> return False
256 foreign import ccall "&rts_stop_next_breakpoint" stepFlag :: Ptr CInt
257 foreign import ccall "&rts_stop_on_exception" exceptionFlag :: Ptr CInt
259 setStepFlag = poke stepFlag 1
260 resetStepFlag = poke stepFlag 0
262 -- this points to the IO action that is executed when a breakpoint is hit
263 foreign import ccall "&rts_breakpoint_io_action"
264 breakPointIOAction :: Ptr (StablePtr (Bool -> BreakInfo -> HValue -> IO ()))
266 -- When running a computation, we redirect ^C exceptions to the running
267 -- thread. ToDo: we might want a way to continue even if the target
268 -- thread doesn't die when it receives the exception... "this thread
269 -- is not responding".
270 sandboxIO :: MVar Status -> IO [HValue] -> IO Status
271 sandboxIO statusMVar thing =
273 (forkIO (do res <- Exception.try (rethrow thing)
274 putMVar statusMVar (Complete res)))
275 (takeMVar statusMVar)
277 -- We want to turn ^C into a break when -fbreak-on-exception is on,
278 -- but it's an async exception and we only break for sync exceptions.
279 -- Idea: if we catch and re-throw it, then the re-throw will trigger
280 -- a break. Great - but we don't want to re-throw all exceptions, because
281 -- then we'll get a double break for ordinary sync exceptions (you'd have
282 -- to :continue twice, which looks strange). So if the exception is
283 -- not "Interrupted", we unset the exception flag before throwing.
285 rethrow :: IO a -> IO a
286 rethrow io = Exception.catch io $ \e -> -- NB. not catchDyn
288 DynException d | Just Interrupted <- fromDynamic d
289 -> Exception.throwIO e
290 _ -> do poke exceptionFlag 0; Exception.throwIO e
293 withInterruptsSentTo :: IO ThreadId -> IO r -> IO r
294 withInterruptsSentTo io get_result = do
295 ts <- takeMVar interruptTargetThread
297 putMVar interruptTargetThread (child:ts)
298 get_result `finally` modifyMVar_ interruptTargetThread (return.tail)
300 -- This function sets up the interpreter for catching breakpoints, and
301 -- resets everything when the computation has stopped running. This
302 -- is a not-very-good way to ensure that only the interactive
303 -- evaluation should generate breakpoints.
304 withBreakAction step dflags breakMVar statusMVar io
305 = bracket setBreakAction resetBreakAction (\_ -> io)
308 stablePtr <- newStablePtr onBreak
309 poke breakPointIOAction stablePtr
310 when (dopt Opt_BreakOnException dflags) $ poke exceptionFlag 1
311 when step $ setStepFlag
313 -- Breaking on exceptions is not enabled by default, since it
314 -- might be a bit surprising. The exception flag is turned off
315 -- as soon as it is hit, or in resetBreakAction below.
317 onBreak is_exception info apStack = do
319 putMVar statusMVar (Break is_exception apStack info tid)
322 resetBreakAction stablePtr = do
323 poke breakPointIOAction noBreakStablePtr
326 freeStablePtr stablePtr
328 noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction
330 noBreakAction False info apStack = putStrLn "*** Ignoring breakpoint"
331 noBreakAction True info apStack = return () -- exception: just continue
333 resume :: Session -> SingleStep -> IO RunResult
334 resume (Session ref) step
336 hsc_env <- readIORef ref
337 let ic = hsc_IC hsc_env
338 resume = ic_resume ic
341 [] -> throwDyn (ProgramError "not stopped at a breakpoint")
343 -- unbind the temporary locals by restoring the TypeEnv from
344 -- before the breakpoint, and drop this Resume from the
345 -- InteractiveContext.
346 let (resume_tmp_ids, resume_tyvars) = resumeBindings r
347 ic' = ic { ic_tmp_ids = resume_tmp_ids,
348 ic_tyvars = resume_tyvars,
350 writeIORef ref hsc_env{ hsc_IC = ic' }
352 -- remove any bindings created since the breakpoint from the
353 -- linker's environment
354 let new_names = map idName (filter (`notElem` resume_tmp_ids)
356 Linker.deleteFromLinkEnv new_names
358 when (isStep step) $ setStepFlag
360 Resume expr tid breakMVar statusMVar bindings
361 final_ids apStack info _ _ _ -> do
362 withBreakAction (isStep step) (hsc_dflags hsc_env)
363 breakMVar statusMVar $ do
364 status <- withInterruptsSentTo
365 (do putMVar breakMVar ()
366 -- this awakens the stopped thread...
368 (takeMVar statusMVar)
369 -- and wait for the result
372 traceRunStatus expr ref bindings final_ids
373 breakMVar statusMVar status emptyHistory
375 handleRunStatus expr ref bindings final_ids
376 breakMVar statusMVar status emptyHistory
379 back :: Session -> IO ([Name], Int, SrcSpan)
382 forward :: Session -> IO ([Name], Int, SrcSpan)
383 forward = moveHist (subtract 1)
385 moveHist fn (Session ref) = do
386 hsc_env <- readIORef ref
387 case ic_resume (hsc_IC hsc_env) of
388 [] -> throwDyn (ProgramError "not stopped at a breakpoint")
390 let ix = resumeHistoryIx r
391 history = resumeHistory r
394 when (new_ix > length history) $
395 throwDyn (ProgramError "no more logged breakpoints")
397 throwDyn (ProgramError "already at the beginning of the history")
400 update_ic apStack mb_info = do
401 (hsc_env1, names, span) <- bindLocalsAtBreakpoint hsc_env
403 let ic = hsc_IC hsc_env1
404 r' = r { resumeHistoryIx = new_ix }
405 ic' = ic { ic_resume = r':rs }
407 writeIORef ref hsc_env1{ hsc_IC = ic' }
409 return (names, new_ix, span)
411 -- careful: we want apStack to be the AP_STACK itself, not a thunk
412 -- around it, hence the cases are carefully constructed below to
413 -- make this the case. ToDo: this is v. fragile, do something better.
416 Resume { resumeApStack = apStack,
417 resumeBreakInfo = mb_info } ->
418 update_ic apStack mb_info
419 else case history !! (new_ix - 1) of
420 History apStack info ->
421 update_ic apStack (Just info)
423 -- -----------------------------------------------------------------------------
424 -- After stopping at a breakpoint, add free variables to the environment
425 result_fs = FSLIT("_result")
427 bindLocalsAtBreakpoint
431 -> IO (HscEnv, [Name], SrcSpan)
433 -- Nothing case: we stopped when an exception was raised, not at a
434 -- breakpoint. We have no location information or local variables to
435 -- bind, all we can do is bind a local variable to the exception
437 bindLocalsAtBreakpoint hsc_env apStack Nothing = do
438 let exn_fs = FSLIT("_exception")
439 exn_name = mkInternalName (getUnique exn_fs) (mkVarOccFS exn_fs) span
441 e_name = mkInternalName (getUnique e_fs) (mkTyVarOcc e_fs) span
442 e_tyvar = mkTcTyVar e_name liftedTypeKind (SkolemTv RuntimeUnkSkol)
443 exn_id = Id.mkGlobalId VanillaGlobal exn_name (mkTyVarTy e_tyvar)
445 new_tyvars = unitVarSet e_tyvar
447 ictxt0 = hsc_IC hsc_env
448 ictxt1 = extendInteractiveContext ictxt0 [exn_id] new_tyvars
450 span = mkGeneralSrcSpan FSLIT("<exception thrown>")
452 Linker.extendLinkEnv [(exn_name, unsafeCoerce# apStack)]
453 return (hsc_env{ hsc_IC = ictxt1 }, [exn_name], span)
455 -- Just case: we stopped at a breakpoint, we have information about the location
456 -- of the breakpoint and the free variables of the expression.
457 bindLocalsAtBreakpoint hsc_env apStack (Just info) = do
460 mod_name = moduleName (breakInfo_module info)
461 mod_details = fmap hm_details (lookupUFM (hsc_HPT hsc_env) mod_name)
462 breaks = md_modBreaks (expectJust "handlRunStatus" mod_details)
463 index = breakInfo_number info
464 vars = breakInfo_vars info
465 result_ty = breakInfo_resty info
466 occs = modBreaks_vars breaks ! index
467 span = modBreaks_locs breaks ! index
469 -- filter out any unboxed ids; we can't bind these at the prompt
470 let pointers = filter (\(id,_) -> isPointer id) vars
471 isPointer id | PtrRep <- idPrimRep id = True
474 let (ids, offsets) = unzip pointers
476 -- It might be that getIdValFromApStack fails, because the AP_STACK
477 -- has been accidentally evaluated, or something else has gone wrong.
478 -- So that we don't fall over in a heap when this happens, just don't
479 -- bind any free variables instead, and we emit a warning.
480 mb_hValues <- mapM (getIdValFromApStack apStack) offsets
481 let (filtered_hvs, filtered_ids) =
482 unzip [ (hv, id) | (id, Just hv) <- zip ids mb_hValues ]
483 when (any isNothing mb_hValues) $
484 debugTraceMsg (hsc_dflags hsc_env) 1 $
485 text "Warning: _result has been evaluated, some bindings have been lost"
487 new_ids <- zipWithM mkNewId occs filtered_ids
488 let names = map idName new_ids
490 -- make an Id for _result. We use the Unique of the FastString "_result";
491 -- we don't care about uniqueness here, because there will only be one
492 -- _result in scope at any time.
493 let result_name = mkInternalName (getUnique result_fs)
494 (mkVarOccFS result_fs) span
495 result_id = Id.mkGlobalId VanillaGlobal result_name result_ty
498 -- for each Id we're about to bind in the local envt:
499 -- - skolemise the type variables in its type, so they can't
500 -- be randomly unified with other types. These type variables
501 -- can only be resolved by type reconstruction in RtClosureInspect
502 -- - tidy the type variables
503 -- - globalise the Id (Ids are supposed to be Global, apparently).
505 let all_ids | isPointer result_id = result_id : new_ids
506 | otherwise = new_ids
507 (id_tys, tyvarss) = mapAndUnzip (skolemiseTy.idType) all_ids
508 (_,tidy_tys) = tidyOpenTypes emptyTidyEnv id_tys
509 new_tyvars = unionVarSets tyvarss
510 let final_ids = zipWith setIdType all_ids tidy_tys
511 ictxt0 = hsc_IC hsc_env
512 ictxt1 = extendInteractiveContext ictxt0 final_ids new_tyvars
513 Linker.extendLinkEnv [ (name,hval) | (name, Just hval) <- zip names mb_hValues ]
514 Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)]
515 hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 }
516 return (hsc_env1, result_name:names, span)
518 mkNewId :: OccName -> Id -> IO Id
520 let uniq = idUnique id
521 loc = nameSrcSpan (idName id)
522 name = mkInternalName uniq occ loc
524 new_id = Id.mkGlobalId VanillaGlobal name ty (idInfo id)
527 rttiEnvironment :: HscEnv -> IO HscEnv
528 rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do
529 let InteractiveContext{ic_tmp_ids=tmp_ids, ic_tyvars = tyvars} = ic
530 incompletelyTypedIds =
532 , not $ null [v | v <- varSetElems$ tyVarsOfType (idType id)
534 , (occNameFS.nameOccName.idName) id /= result_fs]
535 tys <- reconstructType hsc_env False `mapM` incompletelyTypedIds
536 -- map termType `fmap` (obtainTerm hsc_env False `mapM` incompletelyTypedIds)
538 let substs = [computeRTTIsubst ty ty'
539 | (ty, Just ty') <- zip (map idType incompletelyTypedIds) tys]
540 ic' = foldr (flip substInteractiveContext) ic
541 (map skolemiseSubst $ catMaybes substs)
542 return hsc_env{hsc_IC=ic'}
544 skolemiseSubst subst = subst `setTvSubstEnv`
545 mapVarEnv (fst.skolemiseTy) (getTvSubstEnv subst)
547 skolemiseTy :: Type -> (Type, TyVarSet)
548 skolemiseTy ty = (substTy subst ty, mkVarSet new_tyvars)
549 where env = mkVarEnv (zip tyvars new_tyvar_tys)
550 subst = mkTvSubst emptyInScopeSet env
551 tyvars = varSetElems (tyVarsOfType ty)
552 new_tyvars = map skolemiseTyVar tyvars
553 new_tyvar_tys = map mkTyVarTy new_tyvars
555 skolemiseTyVar :: TyVar -> TyVar
556 skolemiseTyVar tyvar = mkTcTyVar (tyVarName tyvar) (tyVarKind tyvar)
557 (SkolemTv RuntimeUnkSkol)
559 getIdValFromApStack :: HValue -> Int -> IO (Maybe HValue)
560 getIdValFromApStack apStack (I# stackDepth) = do
561 case getApStackVal# apStack (stackDepth +# 1#) of
562 -- The +1 is magic! I don't know where it comes
563 -- from, but this makes things line up. --SDM
566 0# -> return Nothing -- AP_STACK not found
567 _ -> return (Just (unsafeCoerce# result))
569 pushResume :: HscEnv -> Resume -> HscEnv
570 pushResume hsc_env resume = hsc_env { hsc_IC = ictxt1 }
572 ictxt0 = hsc_IC hsc_env
573 ictxt1 = ictxt0 { ic_resume = resume : ic_resume ictxt0 }
575 -- -----------------------------------------------------------------------------
576 -- Abandoning a resume context
578 abandon :: Session -> IO Bool
579 abandon (Session ref) = do
580 hsc_env <- readIORef ref
581 let ic = hsc_IC hsc_env
582 resume = ic_resume ic
586 writeIORef ref hsc_env{ hsc_IC = ic { ic_resume = rs } }
590 abandonAll :: Session -> IO Bool
591 abandonAll (Session ref) = do
592 hsc_env <- readIORef ref
593 let ic = hsc_IC hsc_env
594 resume = ic_resume ic
598 writeIORef ref hsc_env{ hsc_IC = ic { ic_resume = [] } }
602 -- when abandoning a computation we have to
603 -- (a) kill the thread with an async exception, so that the
604 -- computation itself is stopped, and
605 -- (b) fill in the MVar. This step is necessary because any
606 -- thunks that were under evaluation will now be updated
607 -- with the partial computation, which still ends in takeMVar,
608 -- so any attempt to evaluate one of these thunks will block
609 -- unless we fill in the MVar.
610 -- See test break010.
611 abandon_ :: Resume -> IO ()
613 killThread (resumeThreadId r)
614 putMVar (resumeBreakMVar r) ()
616 -- -----------------------------------------------------------------------------
617 -- Bounded list, optimised for repeated cons
619 data BoundedList a = BL
620 {-# UNPACK #-} !Int -- length
621 {-# UNPACK #-} !Int -- bound
623 [a] -- right, list is (left ++ reverse right)
625 nilBL :: Int -> BoundedList a
626 nilBL bound = BL 0 bound [] []
628 consBL a (BL len bound left right)
629 | len < bound = BL (len+1) bound (a:left) right
630 | null right = BL len bound [a] $! tail (reverse left)
631 | otherwise = BL len bound (a:left) $! tail right
633 toListBL (BL _ _ left right) = left ++ reverse right
635 -- lenBL (BL len _ _ _) = len
637 -- -----------------------------------------------------------------------------
638 -- | Set the interactive evaluation context.
640 -- Setting the context doesn't throw away any bindings; the bindings
641 -- we've built up in the InteractiveContext simply move to the new
642 -- module. They always shadow anything in scope in the current context.
643 setContext :: Session
644 -> [Module] -- entire top level scope of these modules
645 -> [Module] -- exports only of these modules
647 setContext sess@(Session ref) toplev_mods export_mods = do
648 hsc_env <- readIORef ref
649 let old_ic = hsc_IC hsc_env
650 hpt = hsc_HPT hsc_env
652 export_env <- mkExportEnv hsc_env export_mods
653 toplev_envs <- mapM (mkTopLevEnv hpt) toplev_mods
654 let all_env = foldr plusGlobalRdrEnv export_env toplev_envs
655 writeIORef ref hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplev_mods,
656 ic_exports = export_mods,
657 ic_rn_gbl_env = all_env }}
659 -- Make a GlobalRdrEnv based on the exports of the modules only.
660 mkExportEnv :: HscEnv -> [Module] -> IO GlobalRdrEnv
661 mkExportEnv hsc_env mods = do
662 stuff <- mapM (getModuleExports hsc_env) mods
664 (_msgs, mb_name_sets) = unzip stuff
665 gres = [ nameSetToGlobalRdrEnv (availsToNameSet avails) (moduleName mod)
666 | (Just avails, mod) <- zip mb_name_sets mods ]
668 return $! foldr plusGlobalRdrEnv emptyGlobalRdrEnv gres
670 nameSetToGlobalRdrEnv :: NameSet -> ModuleName -> GlobalRdrEnv
671 nameSetToGlobalRdrEnv names mod =
672 mkGlobalRdrEnv [ GRE { gre_name = name, gre_par = NoParent, gre_prov = vanillaProv mod }
673 | name <- nameSetToList names ]
675 vanillaProv :: ModuleName -> Provenance
676 -- We're building a GlobalRdrEnv as if the user imported
677 -- all the specified modules into the global interactive module
678 vanillaProv mod_name = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}]
680 decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name,
682 is_dloc = srcLocSpan interactiveSrcLoc }
684 mkTopLevEnv :: HomePackageTable -> Module -> IO GlobalRdrEnv
686 = case lookupUFM hpt (moduleName modl) of
687 Nothing -> throwDyn (ProgramError ("mkTopLevEnv: not a home module " ++
688 showSDoc (ppr modl)))
690 case mi_globals (hm_iface details) of
692 throwDyn (ProgramError ("mkTopLevEnv: not interpreted "
693 ++ showSDoc (ppr modl)))
694 Just env -> return env
696 -- | Get the interactive evaluation context, consisting of a pair of the
697 -- set of modules from which we take the full top-level scope, and the set
698 -- of modules from which we take just the exports respectively.
699 getContext :: Session -> IO ([Module],[Module])
700 getContext s = withSession s (\HscEnv{ hsc_IC=ic } ->
701 return (ic_toplev_scope ic, ic_exports ic))
703 -- | Returns 'True' if the specified module is interpreted, and hence has
704 -- its full top-level scope available.
705 moduleIsInterpreted :: Session -> Module -> IO Bool
706 moduleIsInterpreted s modl = withSession s $ \h ->
707 if modulePackageId modl /= thisPackage (hsc_dflags h)
709 else case lookupUFM (hsc_HPT h) (moduleName modl) of
710 Just details -> return (isJust (mi_globals (hm_iface details)))
711 _not_a_home_module -> return False
713 -- | Looks up an identifier in the current interactive context (for :info)
714 getInfo :: Session -> Name -> IO (Maybe (TyThing,Fixity,[Instance]))
715 getInfo s name = withSession s $ \hsc_env -> tcRnGetInfo hsc_env name
717 -- | Returns all names in scope in the current interactive context
718 getNamesInScope :: Session -> IO [Name]
719 getNamesInScope s = withSession s $ \hsc_env -> do
720 return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env))))
722 getRdrNamesInScope :: Session -> IO [RdrName]
723 getRdrNamesInScope s = withSession s $ \hsc_env -> do
726 gbl_rdrenv = ic_rn_gbl_env ic
728 gbl_names = concat (map greToRdrNames (globalRdrEnvElts gbl_rdrenv))
729 lcl_names = map (mkRdrUnqual.nameOccName.idName) ids
731 return (gbl_names ++ lcl_names)
734 -- ToDo: move to RdrName
735 greToRdrNames :: GlobalRdrElt -> [RdrName]
736 greToRdrNames GRE{ gre_name = name, gre_prov = prov }
739 Imported specs -> concat (map do_spec (map is_decl specs))
741 occ = nameOccName name
744 | is_qual decl_spec = [qual]
745 | otherwise = [unqual,qual]
746 where qual = Qual (is_as decl_spec) occ
748 -- | Parses a string as an identifier, and returns the list of 'Name's that
749 -- the identifier can refer to in the current interactive context.
750 parseName :: Session -> String -> IO [Name]
751 parseName s str = withSession s $ \hsc_env -> do
752 maybe_rdr_name <- hscParseIdentifier (hsc_dflags hsc_env) str
753 case maybe_rdr_name of
755 Just (L _ rdr_name) -> do
756 mb_names <- tcRnLookupRdrName hsc_env rdr_name
760 -- ToDo: should return error messages
762 -- | Returns the 'TyThing' for a 'Name'. The 'Name' may refer to any
763 -- entity known to GHC, including 'Name's defined using 'runStmt'.
764 lookupName :: Session -> Name -> IO (Maybe TyThing)
765 lookupName s name = withSession s $ \hsc_env -> tcRnLookupName hsc_env name
767 -- -----------------------------------------------------------------------------
768 -- Getting the type of an expression
770 -- | Get the type of an expression
771 exprType :: Session -> String -> IO (Maybe Type)
772 exprType s expr = withSession s $ \hsc_env -> do
773 maybe_stuff <- hscTcExpr hsc_env expr
775 Nothing -> return Nothing
776 Just ty -> return (Just tidy_ty)
778 tidy_ty = tidyType emptyTidyEnv ty
780 -- -----------------------------------------------------------------------------
781 -- Getting the kind of a type
783 -- | Get the kind of a type
784 typeKind :: Session -> String -> IO (Maybe Kind)
785 typeKind s str = withSession s $ \hsc_env -> do
786 maybe_stuff <- hscKcType hsc_env str
788 Nothing -> return Nothing
789 Just kind -> return (Just kind)
791 -----------------------------------------------------------------------------
792 -- cmCompileExpr: compile an expression and deliver an HValue
794 compileExpr :: Session -> String -> IO (Maybe HValue)
795 compileExpr s expr = withSession s $ \hsc_env -> do
796 maybe_stuff <- hscStmt hsc_env ("let __cmCompileExpr = "++expr)
798 Nothing -> return Nothing
799 Just (ids, hval) -> do
801 hvals <- (unsafeCoerce# hval) :: IO [HValue]
804 ([n],[hv]) -> return (Just hv)
805 _ -> panic "compileExpr"
807 -- -----------------------------------------------------------------------------
808 -- Compile an expression into a dynamic
810 dynCompileExpr :: Session -> String -> IO (Maybe Dynamic)
811 dynCompileExpr ses expr = do
812 (full,exports) <- getContext ses
813 setContext ses full $
815 (stringToPackageId "base") (mkModuleName "Data.Dynamic")
817 let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")"
818 res <- withSession ses (flip hscStmt stmt)
819 setContext ses full exports
821 Nothing -> return Nothing
822 Just (ids, hvals) -> do
823 vals <- (unsafeCoerce# hvals :: IO [Dynamic])
825 (_:[], v:[]) -> return (Just v)
826 _ -> panic "dynCompileExpr"
828 -----------------------------------------------------------------------------
829 -- show a module and it's source/object filenames
831 showModule :: Session -> ModSummary -> IO String
832 showModule s mod_summary = withSession s $ \hsc_env ->
833 isModuleInterpreted s mod_summary >>= \interpreted ->
834 return (showModMsg (hscTarget(hsc_dflags hsc_env)) interpreted mod_summary)
836 isModuleInterpreted :: Session -> ModSummary -> IO Bool
837 isModuleInterpreted s mod_summary = withSession s $ \hsc_env ->
838 case lookupUFM (hsc_HPT hsc_env) (ms_mod_name mod_summary) of
839 Nothing -> panic "missing linkable"
840 Just mod_info -> return (not obj_linkable)
842 obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info))
844 ----------------------------------------------------------------------------
847 obtainTerm1 :: HscEnv -> Bool -> Maybe Type -> a -> IO Term
848 obtainTerm1 hsc_env force mb_ty x =
849 cvObtainTerm hsc_env force mb_ty (unsafeCoerce# x)
851 obtainTerm :: HscEnv -> Bool -> Id -> IO Term
852 obtainTerm hsc_env force id = do
853 hv <- Linker.getHValue hsc_env (varName id)
854 cvObtainTerm hsc_env force (Just$ idType id) hv
856 -- Uses RTTI to reconstruct the type of an Id, making it less polymorphic
857 reconstructType :: HscEnv -> Bool -> Id -> IO (Maybe Type)
858 reconstructType hsc_env force id = do
859 hv <- Linker.getHValue hsc_env (varName id)
860 cvReconstructType hsc_env force (Just$ idType id) hv