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 _ hist _ -> 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
370 let hist' = case info of
371 Nothing -> fromListBL 50 hist
372 Just i -> History apStack i `consBL`
376 traceRunStatus expr ref bindings final_ids
377 breakMVar statusMVar status hist'
379 handleRunStatus expr ref bindings final_ids
380 breakMVar statusMVar status hist'
383 back :: Session -> IO ([Name], Int, SrcSpan)
386 forward :: Session -> IO ([Name], Int, SrcSpan)
387 forward = moveHist (subtract 1)
389 moveHist fn (Session ref) = do
390 hsc_env <- readIORef ref
391 case ic_resume (hsc_IC hsc_env) of
392 [] -> throwDyn (ProgramError "not stopped at a breakpoint")
394 let ix = resumeHistoryIx r
395 history = resumeHistory r
398 when (new_ix > length history) $
399 throwDyn (ProgramError "no more logged breakpoints")
401 throwDyn (ProgramError "already at the beginning of the history")
404 update_ic apStack mb_info = do
405 (hsc_env1, names, span) <- bindLocalsAtBreakpoint hsc_env
407 let ic = hsc_IC hsc_env1
408 r' = r { resumeHistoryIx = new_ix }
409 ic' = ic { ic_resume = r':rs }
411 writeIORef ref hsc_env1{ hsc_IC = ic' }
413 return (names, new_ix, span)
415 -- careful: we want apStack to be the AP_STACK itself, not a thunk
416 -- around it, hence the cases are carefully constructed below to
417 -- make this the case. ToDo: this is v. fragile, do something better.
420 Resume { resumeApStack = apStack,
421 resumeBreakInfo = mb_info } ->
422 update_ic apStack mb_info
423 else case history !! (new_ix - 1) of
424 History apStack info ->
425 update_ic apStack (Just info)
427 -- -----------------------------------------------------------------------------
428 -- After stopping at a breakpoint, add free variables to the environment
429 result_fs = FSLIT("_result")
431 bindLocalsAtBreakpoint
435 -> IO (HscEnv, [Name], SrcSpan)
437 -- Nothing case: we stopped when an exception was raised, not at a
438 -- breakpoint. We have no location information or local variables to
439 -- bind, all we can do is bind a local variable to the exception
441 bindLocalsAtBreakpoint hsc_env apStack Nothing = do
442 let exn_fs = FSLIT("_exception")
443 exn_name = mkInternalName (getUnique exn_fs) (mkVarOccFS exn_fs) span
445 e_name = mkInternalName (getUnique e_fs) (mkTyVarOcc e_fs) span
446 e_tyvar = mkTcTyVar e_name liftedTypeKind (SkolemTv RuntimeUnkSkol)
447 exn_id = Id.mkGlobalId VanillaGlobal exn_name (mkTyVarTy e_tyvar)
449 new_tyvars = unitVarSet e_tyvar
451 ictxt0 = hsc_IC hsc_env
452 ictxt1 = extendInteractiveContext ictxt0 [exn_id] new_tyvars
454 span = mkGeneralSrcSpan FSLIT("<exception thrown>")
456 Linker.extendLinkEnv [(exn_name, unsafeCoerce# apStack)]
457 return (hsc_env{ hsc_IC = ictxt1 }, [exn_name], span)
459 -- Just case: we stopped at a breakpoint, we have information about the location
460 -- of the breakpoint and the free variables of the expression.
461 bindLocalsAtBreakpoint hsc_env apStack (Just info) = do
464 mod_name = moduleName (breakInfo_module info)
465 mod_details = fmap hm_details (lookupUFM (hsc_HPT hsc_env) mod_name)
466 breaks = md_modBreaks (expectJust "handlRunStatus" mod_details)
467 index = breakInfo_number info
468 vars = breakInfo_vars info
469 result_ty = breakInfo_resty info
470 occs = modBreaks_vars breaks ! index
471 span = modBreaks_locs breaks ! index
473 -- filter out any unboxed ids; we can't bind these at the prompt
474 let pointers = filter (\(id,_) -> isPointer id) vars
475 isPointer id | PtrRep <- idPrimRep id = True
478 let (ids, offsets) = unzip pointers
480 -- It might be that getIdValFromApStack fails, because the AP_STACK
481 -- has been accidentally evaluated, or something else has gone wrong.
482 -- So that we don't fall over in a heap when this happens, just don't
483 -- bind any free variables instead, and we emit a warning.
484 mb_hValues <- mapM (getIdValFromApStack apStack) offsets
485 let (filtered_hvs, filtered_ids) =
486 unzip [ (hv, id) | (id, Just hv) <- zip ids mb_hValues ]
487 when (any isNothing mb_hValues) $
488 debugTraceMsg (hsc_dflags hsc_env) 1 $
489 text "Warning: _result has been evaluated, some bindings have been lost"
491 new_ids <- zipWithM mkNewId occs filtered_ids
492 let names = map idName new_ids
494 -- make an Id for _result. We use the Unique of the FastString "_result";
495 -- we don't care about uniqueness here, because there will only be one
496 -- _result in scope at any time.
497 let result_name = mkInternalName (getUnique result_fs)
498 (mkVarOccFS result_fs) span
499 result_id = Id.mkGlobalId VanillaGlobal result_name result_ty
502 -- for each Id we're about to bind in the local envt:
503 -- - skolemise the type variables in its type, so they can't
504 -- be randomly unified with other types. These type variables
505 -- can only be resolved by type reconstruction in RtClosureInspect
506 -- - tidy the type variables
507 -- - globalise the Id (Ids are supposed to be Global, apparently).
509 let all_ids | isPointer result_id = result_id : new_ids
510 | otherwise = new_ids
511 (id_tys, tyvarss) = mapAndUnzip (skolemiseTy.idType) all_ids
512 (_,tidy_tys) = tidyOpenTypes emptyTidyEnv id_tys
513 new_tyvars = unionVarSets tyvarss
514 let final_ids = zipWith setIdType all_ids tidy_tys
515 ictxt0 = hsc_IC hsc_env
516 ictxt1 = extendInteractiveContext ictxt0 final_ids new_tyvars
517 Linker.extendLinkEnv [ (name,hval) | (name, Just hval) <- zip names mb_hValues ]
518 Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)]
519 hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 }
520 return (hsc_env1, result_name:names, span)
522 mkNewId :: OccName -> Id -> IO Id
524 let uniq = idUnique id
525 loc = nameSrcSpan (idName id)
526 name = mkInternalName uniq occ loc
528 new_id = Id.mkGlobalId VanillaGlobal name ty (idInfo id)
531 rttiEnvironment :: HscEnv -> IO HscEnv
532 rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do
533 let InteractiveContext{ic_tmp_ids=tmp_ids, ic_tyvars = tyvars} = ic
534 incompletelyTypedIds =
536 , not $ null [v | v <- varSetElems$ tyVarsOfType (idType id)
538 , (occNameFS.nameOccName.idName) id /= result_fs]
539 tys <- reconstructType hsc_env False `mapM` incompletelyTypedIds
540 -- map termType `fmap` (obtainTerm hsc_env False `mapM` incompletelyTypedIds)
542 let substs = [computeRTTIsubst ty ty'
543 | (ty, Just ty') <- zip (map idType incompletelyTypedIds) tys]
544 ic' = foldr (flip substInteractiveContext) ic
545 (map skolemiseSubst $ catMaybes substs)
546 return hsc_env{hsc_IC=ic'}
548 skolemiseSubst subst = subst `setTvSubstEnv`
549 mapVarEnv (fst.skolemiseTy) (getTvSubstEnv subst)
551 skolemiseTy :: Type -> (Type, TyVarSet)
552 skolemiseTy ty = (substTy subst ty, mkVarSet new_tyvars)
553 where env = mkVarEnv (zip tyvars new_tyvar_tys)
554 subst = mkTvSubst emptyInScopeSet env
555 tyvars = varSetElems (tyVarsOfType ty)
556 new_tyvars = map skolemiseTyVar tyvars
557 new_tyvar_tys = map mkTyVarTy new_tyvars
559 skolemiseTyVar :: TyVar -> TyVar
560 skolemiseTyVar tyvar = mkTcTyVar (tyVarName tyvar) (tyVarKind tyvar)
561 (SkolemTv RuntimeUnkSkol)
563 getIdValFromApStack :: HValue -> Int -> IO (Maybe HValue)
564 getIdValFromApStack apStack (I# stackDepth) = do
565 case getApStackVal# apStack (stackDepth +# 1#) of
566 -- The +1 is magic! I don't know where it comes
567 -- from, but this makes things line up. --SDM
570 0# -> return Nothing -- AP_STACK not found
571 _ -> return (Just (unsafeCoerce# result))
573 pushResume :: HscEnv -> Resume -> HscEnv
574 pushResume hsc_env resume = hsc_env { hsc_IC = ictxt1 }
576 ictxt0 = hsc_IC hsc_env
577 ictxt1 = ictxt0 { ic_resume = resume : ic_resume ictxt0 }
579 -- -----------------------------------------------------------------------------
580 -- Abandoning a resume context
582 abandon :: Session -> IO Bool
583 abandon (Session ref) = do
584 hsc_env <- readIORef ref
585 let ic = hsc_IC hsc_env
586 resume = ic_resume ic
590 writeIORef ref hsc_env{ hsc_IC = ic { ic_resume = rs } }
594 abandonAll :: Session -> IO Bool
595 abandonAll (Session ref) = do
596 hsc_env <- readIORef ref
597 let ic = hsc_IC hsc_env
598 resume = ic_resume ic
602 writeIORef ref hsc_env{ hsc_IC = ic { ic_resume = [] } }
606 -- when abandoning a computation we have to
607 -- (a) kill the thread with an async exception, so that the
608 -- computation itself is stopped, and
609 -- (b) fill in the MVar. This step is necessary because any
610 -- thunks that were under evaluation will now be updated
611 -- with the partial computation, which still ends in takeMVar,
612 -- so any attempt to evaluate one of these thunks will block
613 -- unless we fill in the MVar.
614 -- See test break010.
615 abandon_ :: Resume -> IO ()
617 killThread (resumeThreadId r)
618 putMVar (resumeBreakMVar r) ()
620 -- -----------------------------------------------------------------------------
621 -- Bounded list, optimised for repeated cons
623 data BoundedList a = BL
624 {-# UNPACK #-} !Int -- length
625 {-# UNPACK #-} !Int -- bound
627 [a] -- right, list is (left ++ reverse right)
629 nilBL :: Int -> BoundedList a
630 nilBL bound = BL 0 bound [] []
632 consBL a (BL len bound left right)
633 | len < bound = BL (len+1) bound (a:left) right
634 | null right = BL len bound [a] $! tail (reverse left)
635 | otherwise = BL len bound (a:left) $! tail right
637 toListBL (BL _ _ left right) = left ++ reverse right
639 fromListBL bound l = BL (length l) bound l []
641 -- lenBL (BL len _ _ _) = len
643 -- -----------------------------------------------------------------------------
644 -- | Set the interactive evaluation context.
646 -- Setting the context doesn't throw away any bindings; the bindings
647 -- we've built up in the InteractiveContext simply move to the new
648 -- module. They always shadow anything in scope in the current context.
649 setContext :: Session
650 -> [Module] -- entire top level scope of these modules
651 -> [Module] -- exports only of these modules
653 setContext sess@(Session ref) toplev_mods export_mods = do
654 hsc_env <- readIORef ref
655 let old_ic = hsc_IC hsc_env
656 hpt = hsc_HPT hsc_env
658 export_env <- mkExportEnv hsc_env export_mods
659 toplev_envs <- mapM (mkTopLevEnv hpt) toplev_mods
660 let all_env = foldr plusGlobalRdrEnv export_env toplev_envs
661 writeIORef ref hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplev_mods,
662 ic_exports = export_mods,
663 ic_rn_gbl_env = all_env }}
665 -- Make a GlobalRdrEnv based on the exports of the modules only.
666 mkExportEnv :: HscEnv -> [Module] -> IO GlobalRdrEnv
667 mkExportEnv hsc_env mods = do
668 stuff <- mapM (getModuleExports hsc_env) mods
670 (_msgs, mb_name_sets) = unzip stuff
671 gres = [ nameSetToGlobalRdrEnv (availsToNameSet avails) (moduleName mod)
672 | (Just avails, mod) <- zip mb_name_sets mods ]
674 return $! foldr plusGlobalRdrEnv emptyGlobalRdrEnv gres
676 nameSetToGlobalRdrEnv :: NameSet -> ModuleName -> GlobalRdrEnv
677 nameSetToGlobalRdrEnv names mod =
678 mkGlobalRdrEnv [ GRE { gre_name = name, gre_par = NoParent, gre_prov = vanillaProv mod }
679 | name <- nameSetToList names ]
681 vanillaProv :: ModuleName -> Provenance
682 -- We're building a GlobalRdrEnv as if the user imported
683 -- all the specified modules into the global interactive module
684 vanillaProv mod_name = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}]
686 decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name,
688 is_dloc = srcLocSpan interactiveSrcLoc }
690 mkTopLevEnv :: HomePackageTable -> Module -> IO GlobalRdrEnv
692 = case lookupUFM hpt (moduleName modl) of
693 Nothing -> throwDyn (ProgramError ("mkTopLevEnv: not a home module " ++
694 showSDoc (ppr modl)))
696 case mi_globals (hm_iface details) of
698 throwDyn (ProgramError ("mkTopLevEnv: not interpreted "
699 ++ showSDoc (ppr modl)))
700 Just env -> return env
702 -- | Get the interactive evaluation context, consisting of a pair of the
703 -- set of modules from which we take the full top-level scope, and the set
704 -- of modules from which we take just the exports respectively.
705 getContext :: Session -> IO ([Module],[Module])
706 getContext s = withSession s (\HscEnv{ hsc_IC=ic } ->
707 return (ic_toplev_scope ic, ic_exports ic))
709 -- | Returns 'True' if the specified module is interpreted, and hence has
710 -- its full top-level scope available.
711 moduleIsInterpreted :: Session -> Module -> IO Bool
712 moduleIsInterpreted s modl = withSession s $ \h ->
713 if modulePackageId modl /= thisPackage (hsc_dflags h)
715 else case lookupUFM (hsc_HPT h) (moduleName modl) of
716 Just details -> return (isJust (mi_globals (hm_iface details)))
717 _not_a_home_module -> return False
719 -- | Looks up an identifier in the current interactive context (for :info)
720 -- Filter the instances by the ones whose tycons (or clases resp)
721 -- are in scope (qualified or otherwise). Otherwise we list a whole lot too many!
722 -- The exact choice of which ones to show, and which to hide, is a judgement call.
724 getInfo :: Session -> Name -> IO (Maybe (TyThing,Fixity,[Instance]))
726 = withSession s $ \hsc_env ->
727 do { mb_stuff <- tcRnGetInfo hsc_env name
729 Nothing -> return Nothing
730 Just (thing, fixity, ispecs) -> do
731 { let rdr_env = ic_rn_gbl_env (hsc_IC hsc_env)
732 ; return (Just (thing, fixity, filter (plausible rdr_env) ispecs)) } }
734 plausible rdr_env ispec -- Dfun involving only names that are in ic_rn_glb_env
735 = all ok $ nameSetToList $ tyClsNamesOfType $ idType $ instanceDFunId ispec
736 where -- A name is ok if it's in the rdr_env,
737 -- whether qualified or not
738 ok n | n == name = True -- The one we looked for in the first place!
739 | isBuiltInSyntax n = True
740 | isExternalName n = any ((== n) . gre_name)
741 (lookupGRE_Name rdr_env n)
744 -- | Returns all names in scope in the current interactive context
745 getNamesInScope :: Session -> IO [Name]
746 getNamesInScope s = withSession s $ \hsc_env -> do
747 return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env))))
749 getRdrNamesInScope :: Session -> IO [RdrName]
750 getRdrNamesInScope s = withSession s $ \hsc_env -> do
753 gbl_rdrenv = ic_rn_gbl_env ic
755 gbl_names = concat (map greToRdrNames (globalRdrEnvElts gbl_rdrenv))
756 lcl_names = map (mkRdrUnqual.nameOccName.idName) ids
758 return (gbl_names ++ lcl_names)
761 -- ToDo: move to RdrName
762 greToRdrNames :: GlobalRdrElt -> [RdrName]
763 greToRdrNames GRE{ gre_name = name, gre_prov = prov }
766 Imported specs -> concat (map do_spec (map is_decl specs))
768 occ = nameOccName name
771 | is_qual decl_spec = [qual]
772 | otherwise = [unqual,qual]
773 where qual = Qual (is_as decl_spec) occ
775 -- | Parses a string as an identifier, and returns the list of 'Name's that
776 -- the identifier can refer to in the current interactive context.
777 parseName :: Session -> String -> IO [Name]
778 parseName s str = withSession s $ \hsc_env -> do
779 maybe_rdr_name <- hscParseIdentifier (hsc_dflags hsc_env) str
780 case maybe_rdr_name of
782 Just (L _ rdr_name) -> do
783 mb_names <- tcRnLookupRdrName hsc_env rdr_name
787 -- ToDo: should return error messages
789 -- | Returns the 'TyThing' for a 'Name'. The 'Name' may refer to any
790 -- entity known to GHC, including 'Name's defined using 'runStmt'.
791 lookupName :: Session -> Name -> IO (Maybe TyThing)
792 lookupName s name = withSession s $ \hsc_env -> tcRnLookupName hsc_env name
794 -- -----------------------------------------------------------------------------
795 -- Getting the type of an expression
797 -- | Get the type of an expression
798 exprType :: Session -> String -> IO (Maybe Type)
799 exprType s expr = withSession s $ \hsc_env -> do
800 maybe_stuff <- hscTcExpr hsc_env expr
802 Nothing -> return Nothing
803 Just ty -> return (Just tidy_ty)
805 tidy_ty = tidyType emptyTidyEnv ty
807 -- -----------------------------------------------------------------------------
808 -- Getting the kind of a type
810 -- | Get the kind of a type
811 typeKind :: Session -> String -> IO (Maybe Kind)
812 typeKind s str = withSession s $ \hsc_env -> do
813 maybe_stuff <- hscKcType hsc_env str
815 Nothing -> return Nothing
816 Just kind -> return (Just kind)
818 -----------------------------------------------------------------------------
819 -- cmCompileExpr: compile an expression and deliver an HValue
821 compileExpr :: Session -> String -> IO (Maybe HValue)
822 compileExpr s expr = withSession s $ \hsc_env -> do
823 maybe_stuff <- hscStmt hsc_env ("let __cmCompileExpr = "++expr)
825 Nothing -> return Nothing
826 Just (ids, hval) -> do
828 hvals <- (unsafeCoerce# hval) :: IO [HValue]
831 ([n],[hv]) -> return (Just hv)
832 _ -> panic "compileExpr"
834 -- -----------------------------------------------------------------------------
835 -- Compile an expression into a dynamic
837 dynCompileExpr :: Session -> String -> IO (Maybe Dynamic)
838 dynCompileExpr ses expr = do
839 (full,exports) <- getContext ses
840 setContext ses full $
842 (stringToPackageId "base") (mkModuleName "Data.Dynamic")
844 let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")"
845 res <- withSession ses (flip hscStmt stmt)
846 setContext ses full exports
848 Nothing -> return Nothing
849 Just (ids, hvals) -> do
850 vals <- (unsafeCoerce# hvals :: IO [Dynamic])
852 (_:[], v:[]) -> return (Just v)
853 _ -> panic "dynCompileExpr"
855 -----------------------------------------------------------------------------
856 -- show a module and it's source/object filenames
858 showModule :: Session -> ModSummary -> IO String
859 showModule s mod_summary = withSession s $ \hsc_env ->
860 isModuleInterpreted s mod_summary >>= \interpreted ->
861 return (showModMsg (hscTarget(hsc_dflags hsc_env)) interpreted mod_summary)
863 isModuleInterpreted :: Session -> ModSummary -> IO Bool
864 isModuleInterpreted s mod_summary = withSession s $ \hsc_env ->
865 case lookupUFM (hsc_HPT hsc_env) (ms_mod_name mod_summary) of
866 Nothing -> panic "missing linkable"
867 Just mod_info -> return (not obj_linkable)
869 obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info))
871 ----------------------------------------------------------------------------
874 obtainTerm1 :: HscEnv -> Bool -> Maybe Type -> a -> IO Term
875 obtainTerm1 hsc_env force mb_ty x =
876 cvObtainTerm hsc_env force mb_ty (unsafeCoerce# x)
878 obtainTerm :: HscEnv -> Bool -> Id -> IO Term
879 obtainTerm hsc_env force id = do
880 hv <- Linker.getHValue hsc_env (varName id)
881 cvObtainTerm hsc_env force (Just$ idType id) hv
883 -- Uses RTTI to reconstruct the type of an Id, making it less polymorphic
884 reconstructType :: HscEnv -> Bool -> Id -> IO (Maybe Type)
885 reconstructType hsc_env force id = do
886 hv <- Linker.getHValue hsc_env (varName id)
887 cvReconstructType hsc_env force (Just$ idType id) hv