FIX: break011.
[ghc.git] / compiler / main / InteractiveEval.hs
1 -- -----------------------------------------------------------------------------
2 --
3 -- (c) The University of Glasgow, 2005-2007
4 --
5 -- Running statements interactively
6 --
7 -- -----------------------------------------------------------------------------
8
9 module InteractiveEval (
10 #ifdef GHCI
11 RunResult(..), Status(..), Resume(..), History(..),
12 runStmt, SingleStep(..),
13 resume,
14 abandon, abandonAll,
15 getResumeContext,
16 getHistorySpan,
17 back, forward,
18 setContext, getContext,
19 nameSetToGlobalRdrEnv,
20 getNamesInScope,
21 getRdrNamesInScope,
22 moduleIsInterpreted,
23 getInfo,
24 exprType,
25 typeKind,
26 parseName,
27 showModule,
28 isModuleInterpreted,
29 compileExpr, dynCompileExpr,
30 lookupName,
31 obtainTerm, obtainTerm1
32 #endif
33 ) where
34
35 #ifdef GHCI
36
37 #include "HsVersions.h"
38
39 import HscMain hiding (compileExpr)
40 import HscTypes
41 import TcRnDriver
42 import Type hiding (typeKind)
43 import TcType hiding (typeKind)
44 import InstEnv
45 import Var hiding (setIdType)
46 import Id
47 import IdInfo
48 import Name hiding ( varName )
49 import NameSet
50 import RdrName
51 import VarSet
52 import VarEnv
53 import ByteCodeInstr
54 import Linker
55 import DynFlags
56 import Unique
57 import Module
58 import Panic
59 import UniqFM
60 import Maybes
61 import ErrUtils
62 import Util
63 import SrcLoc
64 import BreakArray
65 import RtClosureInspect
66 import Packages
67 import BasicTypes
68 import Outputable
69
70 import Data.Dynamic
71 import Control.Monad
72 import Foreign
73 import Foreign.C
74 import GHC.Exts
75 import Data.Array
76 import Control.Exception as Exception
77 import Control.Concurrent
78 import Data.IORef
79 import Foreign.StablePtr
80
81 -- -----------------------------------------------------------------------------
82 -- running a statement interactively
83
84 data RunResult
85 = RunOk [Name] -- ^ names bound by this evaluation
86 | RunFailed -- ^ statement failed compilation
87 | RunException Exception -- ^ statement raised an exception
88 | RunBreak ThreadId [Name] (Maybe BreakInfo)
89
90 data Status
91 = Break Bool HValue BreakInfo ThreadId
92 -- ^ the computation hit a breakpoint (Bool <=> was an exception)
93 | Complete (Either Exception [HValue])
94 -- ^ the computation completed with either an exception or a value
95
96 data Resume
97 = Resume {
98 resumeStmt :: String, -- the original statement
99 resumeThreadId :: ThreadId, -- thread running the computation
100 resumeBreakMVar :: MVar (),
101 resumeStatMVar :: MVar Status,
102 resumeBindings :: ([Id], TyVarSet),
103 resumeFinalIds :: [Id], -- [Id] to bind on completion
104 resumeApStack :: HValue, -- The object from which we can get
105 -- value of the free variables.
106 resumeBreakInfo :: Maybe BreakInfo,
107 -- the breakpoint we stopped at
108 -- (Nothing <=> exception)
109 resumeSpan :: SrcSpan, -- just a cache, otherwise it's a pain
110 -- to fetch the ModDetails & ModBreaks
111 -- to get this.
112 resumeHistory :: [History],
113 resumeHistoryIx :: Int -- 0 <==> at the top of the history
114 }
115
116 getResumeContext :: Session -> IO [Resume]
117 getResumeContext s = withSession s (return . ic_resume . hsc_IC)
118
119 data SingleStep
120 = RunToCompletion
121 | SingleStep
122 | RunAndLogSteps
123
124 isStep RunToCompletion = False
125 isStep _ = True
126
127 data History
128 = History {
129 historyApStack :: HValue,
130 historyBreakInfo :: BreakInfo
131 }
132
133 getHistorySpan :: Session -> History -> IO SrcSpan
134 getHistorySpan s hist = withSession s $ \hsc_env -> do
135 let inf = historyBreakInfo hist
136 num = breakInfo_number inf
137 case lookupUFM (hsc_HPT hsc_env) (moduleName (breakInfo_module inf)) of
138 Just hmi -> return (modBreaks_locs (md_modBreaks (hm_details hmi)) ! num)
139 _ -> panic "getHistorySpan"
140
141 -- | Run a statement in the current interactive context. Statement
142 -- may bind multple values.
143 runStmt :: Session -> String -> SingleStep -> IO RunResult
144 runStmt (Session ref) expr step
145 = do
146 hsc_env <- readIORef ref
147
148 breakMVar <- newEmptyMVar -- wait on this when we hit a breakpoint
149 statusMVar <- newEmptyMVar -- wait on this when a computation is running
150
151 -- Turn off -fwarn-unused-bindings when running a statement, to hide
152 -- warnings about the implicit bindings we introduce.
153 let dflags' = dopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds
154 hsc_env' = hsc_env{ hsc_dflags = dflags' }
155
156 maybe_stuff <- hscStmt hsc_env' expr
157
158 case maybe_stuff of
159 Nothing -> return RunFailed
160 Just (ids, hval) -> do
161
162 withBreakAction (isStep step) dflags' breakMVar statusMVar $ do
163
164 let thing_to_run = unsafeCoerce# hval :: IO [HValue]
165 status <- sandboxIO statusMVar thing_to_run
166
167 let ic = hsc_IC hsc_env
168 bindings = (ic_tmp_ids ic, ic_tyvars ic)
169
170 case step of
171 RunAndLogSteps ->
172 traceRunStatus expr ref bindings ids
173 breakMVar statusMVar status emptyHistory
174 _other ->
175 handleRunStatus expr ref bindings ids
176 breakMVar statusMVar status emptyHistory
177
178
179 emptyHistory = nilBL 50 -- keep a log of length 50
180
181 handleRunStatus expr ref bindings final_ids breakMVar statusMVar status
182 history =
183 case status of
184 -- did we hit a breakpoint or did we complete?
185 (Break is_exception apStack info tid) -> do
186 hsc_env <- readIORef ref
187 let mb_info | is_exception = Nothing
188 | otherwise = Just info
189 (hsc_env1, names, span) <- bindLocalsAtBreakpoint hsc_env
190 apStack mb_info
191 let
192 resume = Resume expr tid breakMVar statusMVar
193 bindings final_ids apStack mb_info span
194 (toListBL history) 0
195 hsc_env2 = pushResume hsc_env1 resume
196 --
197 writeIORef ref hsc_env2
198 return (RunBreak tid names mb_info)
199 (Complete either_hvals) ->
200 case either_hvals of
201 Left e -> return (RunException e)
202 Right hvals -> do
203 hsc_env <- readIORef ref
204 let final_ic = extendInteractiveContext (hsc_IC hsc_env)
205 final_ids emptyVarSet
206 -- the bound Ids never have any free TyVars
207 final_names = map idName final_ids
208 writeIORef ref hsc_env{hsc_IC=final_ic}
209 Linker.extendLinkEnv (zip final_names hvals)
210 return (RunOk final_names)
211
212
213 traceRunStatus expr ref bindings final_ids
214 breakMVar statusMVar status history = do
215 hsc_env <- readIORef ref
216 case status of
217 -- when tracing, if we hit a breakpoint that is not explicitly
218 -- enabled, then we just log the event in the history and continue.
219 (Break is_exception apStack info tid) | not is_exception -> do
220 b <- isBreakEnabled hsc_env info
221 if b
222 then handle_normally
223 else do
224 let history' = consBL (History apStack info) history
225 -- probably better make history strict here, otherwise
226 -- our BoundedList will be pointless.
227 evaluate history'
228 status <- withBreakAction True (hsc_dflags hsc_env)
229 breakMVar statusMVar $ do
230 withInterruptsSentTo
231 (do putMVar breakMVar () -- awaken the stopped thread
232 return tid)
233 (takeMVar statusMVar) -- and wait for the result
234 traceRunStatus expr ref bindings final_ids
235 breakMVar statusMVar status history'
236 _other ->
237 handle_normally
238 where
239 handle_normally = handleRunStatus expr ref bindings final_ids
240 breakMVar statusMVar status history
241
242
243 isBreakEnabled :: HscEnv -> BreakInfo -> IO Bool
244 isBreakEnabled hsc_env inf =
245 case lookupUFM (hsc_HPT hsc_env) (moduleName (breakInfo_module inf)) of
246 Just hmi -> do
247 w <- getBreak (modBreaks_flags (md_modBreaks (hm_details hmi)))
248 (breakInfo_number inf)
249 case w of Just n -> return (n /= 0); _other -> return False
250 _ ->
251 return False
252
253
254 foreign import ccall "&rts_stop_next_breakpoint" stepFlag :: Ptr CInt
255 foreign import ccall "&rts_stop_on_exception" exceptionFlag :: Ptr CInt
256
257 setStepFlag = poke stepFlag 1
258 resetStepFlag = poke stepFlag 0
259
260 -- this points to the IO action that is executed when a breakpoint is hit
261 foreign import ccall "&rts_breakpoint_io_action"
262 breakPointIOAction :: Ptr (StablePtr (Bool -> BreakInfo -> HValue -> IO ()))
263
264 -- When running a computation, we redirect ^C exceptions to the running
265 -- thread. ToDo: we might want a way to continue even if the target
266 -- thread doesn't die when it receives the exception... "this thread
267 -- is not responding".
268 sandboxIO :: MVar Status -> IO [HValue] -> IO Status
269 sandboxIO statusMVar thing =
270 withInterruptsSentTo
271 (forkIO (do res <- Exception.try (rethrow thing)
272 putMVar statusMVar (Complete res)))
273 (takeMVar statusMVar)
274
275 -- We want to turn ^C into a break when -fbreak-on-exception is on,
276 -- but it's an async exception and we only break for sync exceptions.
277 -- Idea: if we catch and re-throw it, then the re-throw will trigger
278 -- a break. Great - but we don't want to re-throw all exceptions, because
279 -- then we'll get a double break for ordinary sync exceptions (you'd have
280 -- to :continue twice, which looks strange). So if the exception is
281 -- not "Interrupted", we unset the exception flag before throwing.
282 --
283 rethrow :: IO a -> IO a
284 rethrow io = Exception.catch io $ \e -> -- NB. not catchDyn
285 case e of
286 DynException d | Just Interrupted <- fromDynamic d
287 -> Exception.throwIO e
288 _ -> do poke exceptionFlag 0; Exception.throwIO e
289
290
291 withInterruptsSentTo :: IO ThreadId -> IO r -> IO r
292 withInterruptsSentTo io get_result = do
293 ts <- takeMVar interruptTargetThread
294 child <- io
295 putMVar interruptTargetThread (child:ts)
296 get_result `finally` modifyMVar_ interruptTargetThread (return.tail)
297
298 -- This function sets up the interpreter for catching breakpoints, and
299 -- resets everything when the computation has stopped running. This
300 -- is a not-very-good way to ensure that only the interactive
301 -- evaluation should generate breakpoints.
302 withBreakAction step dflags breakMVar statusMVar io
303 = bracket setBreakAction resetBreakAction (\_ -> io)
304 where
305 setBreakAction = do
306 stablePtr <- newStablePtr onBreak
307 poke breakPointIOAction stablePtr
308 when (dopt Opt_BreakOnException dflags) $ poke exceptionFlag 1
309 when step $ setStepFlag
310 return stablePtr
311 -- Breaking on exceptions is not enabled by default, since it
312 -- might be a bit surprising. The exception flag is turned off
313 -- as soon as it is hit, or in resetBreakAction below.
314
315 onBreak is_exception info apStack = do
316 tid <- myThreadId
317 putMVar statusMVar (Break is_exception apStack info tid)
318 takeMVar breakMVar
319
320 resetBreakAction stablePtr = do
321 poke breakPointIOAction noBreakStablePtr
322 poke exceptionFlag 0
323 resetStepFlag
324 freeStablePtr stablePtr
325
326 noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction
327
328 noBreakAction False info apStack = putStrLn "*** Ignoring breakpoint"
329 noBreakAction True info apStack = return () -- exception: just continue
330
331 resume :: Session -> SingleStep -> IO RunResult
332 resume (Session ref) step
333 = do
334 hsc_env <- readIORef ref
335 let ic = hsc_IC hsc_env
336 resume = ic_resume ic
337
338 case resume of
339 [] -> throwDyn (ProgramError "not stopped at a breakpoint")
340 (r:rs) -> do
341 -- unbind the temporary locals by restoring the TypeEnv from
342 -- before the breakpoint, and drop this Resume from the
343 -- InteractiveContext.
344 let (resume_tmp_ids, resume_tyvars) = resumeBindings r
345 ic' = ic { ic_tmp_ids = resume_tmp_ids,
346 ic_tyvars = resume_tyvars,
347 ic_resume = rs }
348 writeIORef ref hsc_env{ hsc_IC = ic' }
349
350 -- remove any bindings created since the breakpoint from the
351 -- linker's environment
352 let new_names = map idName (filter (`notElem` resume_tmp_ids)
353 (ic_tmp_ids ic))
354 Linker.deleteFromLinkEnv new_names
355
356 when (isStep step) $ setStepFlag
357 case r of
358 Resume expr tid breakMVar statusMVar bindings
359 final_ids apStack info _ _ _ -> do
360 withBreakAction (isStep step) (hsc_dflags hsc_env)
361 breakMVar statusMVar $ do
362 status <- withInterruptsSentTo
363 (do putMVar breakMVar ()
364 -- this awakens the stopped thread...
365 return tid)
366 (takeMVar statusMVar)
367 -- and wait for the result
368 case step of
369 RunAndLogSteps ->
370 traceRunStatus expr ref bindings final_ids
371 breakMVar statusMVar status emptyHistory
372 _other ->
373 handleRunStatus expr ref bindings final_ids
374 breakMVar statusMVar status emptyHistory
375
376
377 back :: Session -> IO ([Name], Int, SrcSpan)
378 back = moveHist (+1)
379
380 forward :: Session -> IO ([Name], Int, SrcSpan)
381 forward = moveHist (subtract 1)
382
383 moveHist fn (Session ref) = do
384 hsc_env <- readIORef ref
385 case ic_resume (hsc_IC hsc_env) of
386 [] -> throwDyn (ProgramError "not stopped at a breakpoint")
387 (r:rs) -> do
388 let ix = resumeHistoryIx r
389 history = resumeHistory r
390 new_ix = fn ix
391 --
392 when (new_ix > length history) $
393 throwDyn (ProgramError "no more logged breakpoints")
394 when (new_ix < 0) $
395 throwDyn (ProgramError "already at the beginning of the history")
396
397 let
398 update_ic apStack mb_info = do
399 (hsc_env1, names, span) <- bindLocalsAtBreakpoint hsc_env
400 apStack mb_info
401 let ic = hsc_IC hsc_env1
402 r' = r { resumeHistoryIx = new_ix }
403 ic' = ic { ic_resume = r':rs }
404
405 writeIORef ref hsc_env1{ hsc_IC = ic' }
406
407 return (names, new_ix, span)
408
409 -- careful: we want apStack to be the AP_STACK itself, not a thunk
410 -- around it, hence the cases are carefully constructed below to
411 -- make this the case. ToDo: this is v. fragile, do something better.
412 if new_ix == 0
413 then case r of
414 Resume { resumeApStack = apStack,
415 resumeBreakInfo = mb_info } ->
416 update_ic apStack mb_info
417 else case history !! (new_ix - 1) of
418 History apStack info ->
419 update_ic apStack (Just info)
420
421 -- -----------------------------------------------------------------------------
422 -- After stopping at a breakpoint, add free variables to the environment
423
424 bindLocalsAtBreakpoint
425 :: HscEnv
426 -> HValue
427 -> Maybe BreakInfo
428 -> IO (HscEnv, [Name], SrcSpan)
429
430 -- Nothing case: we stopped when an exception was raised, not at a
431 -- breakpoint. We have no location information or local variables to
432 -- bind, all we can do is bind a local variable to the exception
433 -- value.
434 bindLocalsAtBreakpoint hsc_env apStack Nothing = do
435 let exn_fs = FSLIT("_exception")
436 exn_name = mkInternalName (getUnique exn_fs) (mkVarOccFS exn_fs) span
437 e_fs = FSLIT("e")
438 e_name = mkInternalName (getUnique e_fs) (mkTyVarOcc e_fs) span
439 e_tyvar = mkTcTyVar e_name liftedTypeKind (SkolemTv RuntimeUnkSkol)
440 exn_id = Id.mkGlobalId VanillaGlobal exn_name (mkTyVarTy e_tyvar)
441 vanillaIdInfo
442 new_tyvars = unitVarSet e_tyvar
443
444 ictxt0 = hsc_IC hsc_env
445 ictxt1 = extendInteractiveContext ictxt0 [exn_id] new_tyvars
446
447 span = mkGeneralSrcSpan FSLIT("<exception thrown>")
448 --
449 Linker.extendLinkEnv [(exn_name, unsafeCoerce# apStack)]
450 return (hsc_env{ hsc_IC = ictxt1 }, [exn_name], span)
451
452 -- Just case: we stopped at a breakpoint, we have information about the location
453 -- of the breakpoint and the free variables of the expression.
454 bindLocalsAtBreakpoint hsc_env apStack (Just info) = do
455
456 let
457 mod_name = moduleName (breakInfo_module info)
458 mod_details = fmap hm_details (lookupUFM (hsc_HPT hsc_env) mod_name)
459 breaks = md_modBreaks (expectJust "handlRunStatus" mod_details)
460 index = breakInfo_number info
461 vars = breakInfo_vars info
462 result_ty = breakInfo_resty info
463 occs = modBreaks_vars breaks ! index
464 span = modBreaks_locs breaks ! index
465
466 -- filter out any unboxed ids; we can't bind these at the prompt
467 let pointers = filter (\(id,_) -> isPointer id) vars
468 isPointer id | PtrRep <- idPrimRep id = True
469 | otherwise = False
470
471 let (ids, offsets) = unzip pointers
472
473 -- It might be that getIdValFromApStack fails, because the AP_STACK
474 -- has been accidentally evaluated, or something else has gone wrong.
475 -- So that we don't fall over in a heap when this happens, just don't
476 -- bind any free variables instead, and we emit a warning.
477 mb_hValues <- mapM (getIdValFromApStack apStack) offsets
478 let filtered_ids = [ id | (id, Just _) <- zip ids mb_hValues ]
479 when (any isNothing mb_hValues) $
480 debugTraceMsg (hsc_dflags hsc_env) 1 $
481 text "Warning: _result has been evaluated, some bindings have been lost"
482
483 new_ids <- zipWithM mkNewId occs filtered_ids
484 let names = map idName new_ids
485
486 -- make an Id for _result. We use the Unique of the FastString "_result";
487 -- we don't care about uniqueness here, because there will only be one
488 -- _result in scope at any time.
489 let result_fs = FSLIT("_result")
490 result_name = mkInternalName (getUnique result_fs)
491 (mkVarOccFS result_fs) span
492 result_id = Id.mkGlobalId VanillaGlobal result_name result_ty
493 vanillaIdInfo
494
495 -- for each Id we're about to bind in the local envt:
496 -- - skolemise the type variables in its type, so they can't
497 -- be randomly unified with other types. These type variables
498 -- can only be resolved by type reconstruction in RtClosureInspect
499 -- - tidy the type variables
500 -- - globalise the Id (Ids are supposed to be Global, apparently).
501 --
502 let all_ids | isPointer result_id = result_id : new_ids
503 | otherwise = new_ids
504 (id_tys, tyvarss) = mapAndUnzip (skolemiseTy.idType) all_ids
505 (_,tidy_tys) = tidyOpenTypes emptyTidyEnv id_tys
506 new_tyvars = unionVarSets tyvarss
507 final_ids = zipWith setIdType all_ids tidy_tys
508
509 let ictxt0 = hsc_IC hsc_env
510 ictxt1 = extendInteractiveContext ictxt0 final_ids new_tyvars
511
512 Linker.extendLinkEnv [ (name,hval) | (name, Just hval) <- zip names mb_hValues ]
513 Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)]
514 return (hsc_env{ hsc_IC = ictxt1 }, result_name:names, span)
515 where
516 mkNewId :: OccName -> Id -> IO Id
517 mkNewId occ id = do
518 let uniq = idUnique id
519 loc = nameSrcSpan (idName id)
520 name = mkInternalName uniq occ loc
521 ty = idType id
522 new_id = Id.mkGlobalId VanillaGlobal name ty (idInfo id)
523 return new_id
524
525 skolemiseTy :: Type -> (Type, TyVarSet)
526 skolemiseTy ty = (substTy subst ty, mkVarSet new_tyvars)
527 where env = mkVarEnv (zip tyvars new_tyvar_tys)
528 subst = mkTvSubst emptyInScopeSet env
529 tyvars = varSetElems (tyVarsOfType ty)
530 new_tyvars = map skolemiseTyVar tyvars
531 new_tyvar_tys = map mkTyVarTy new_tyvars
532
533 skolemiseTyVar :: TyVar -> TyVar
534 skolemiseTyVar tyvar = mkTcTyVar (tyVarName tyvar) (tyVarKind tyvar)
535 (SkolemTv RuntimeUnkSkol)
536
537 getIdValFromApStack :: HValue -> Int -> IO (Maybe HValue)
538 getIdValFromApStack apStack (I# stackDepth) = do
539 case getApStackVal# apStack (stackDepth +# 1#) of
540 -- The +1 is magic! I don't know where it comes
541 -- from, but this makes things line up. --SDM
542 (# ok, result #) ->
543 case ok of
544 0# -> return Nothing -- AP_STACK not found
545 _ -> return (Just (unsafeCoerce# result))
546
547 pushResume :: HscEnv -> Resume -> HscEnv
548 pushResume hsc_env resume = hsc_env { hsc_IC = ictxt1 }
549 where
550 ictxt0 = hsc_IC hsc_env
551 ictxt1 = ictxt0 { ic_resume = resume : ic_resume ictxt0 }
552
553 -- -----------------------------------------------------------------------------
554 -- Abandoning a resume context
555
556 abandon :: Session -> IO Bool
557 abandon (Session ref) = do
558 hsc_env <- readIORef ref
559 let ic = hsc_IC hsc_env
560 resume = ic_resume ic
561 case resume of
562 [] -> return False
563 r:rs -> do
564 writeIORef ref hsc_env{ hsc_IC = ic { ic_resume = rs } }
565 abandon_ r
566 return True
567
568 abandonAll :: Session -> IO Bool
569 abandonAll (Session ref) = do
570 hsc_env <- readIORef ref
571 let ic = hsc_IC hsc_env
572 resume = ic_resume ic
573 case resume of
574 [] -> return False
575 rs -> do
576 writeIORef ref hsc_env{ hsc_IC = ic { ic_resume = [] } }
577 mapM_ abandon_ rs
578 return True
579
580 -- when abandoning a computation we have to
581 -- (a) kill the thread with an async exception, so that the
582 -- computation itself is stopped, and
583 -- (b) fill in the MVar. This step is necessary because any
584 -- thunks that were under evaluation will now be updated
585 -- with the partial computation, which still ends in takeMVar,
586 -- so any attempt to evaluate one of these thunks will block
587 -- unless we fill in the MVar.
588 -- See test break010.
589 abandon_ :: Resume -> IO ()
590 abandon_ r = do
591 killThread (resumeThreadId r)
592 putMVar (resumeBreakMVar r) ()
593
594 -- -----------------------------------------------------------------------------
595 -- Bounded list, optimised for repeated cons
596
597 data BoundedList a = BL
598 {-# UNPACK #-} !Int -- length
599 {-# UNPACK #-} !Int -- bound
600 [a] -- left
601 [a] -- right, list is (left ++ reverse right)
602
603 nilBL :: Int -> BoundedList a
604 nilBL bound = BL 0 bound [] []
605
606 consBL a (BL len bound left right)
607 | len < bound = BL (len+1) bound (a:left) right
608 | null right = BL len bound [a] $! tail (reverse left)
609 | otherwise = BL len bound (a:left) $! tail right
610
611 toListBL (BL _ _ left right) = left ++ reverse right
612
613 -- lenBL (BL len _ _ _) = len
614
615 -- -----------------------------------------------------------------------------
616 -- | Set the interactive evaluation context.
617 --
618 -- Setting the context doesn't throw away any bindings; the bindings
619 -- we've built up in the InteractiveContext simply move to the new
620 -- module. They always shadow anything in scope in the current context.
621 setContext :: Session
622 -> [Module] -- entire top level scope of these modules
623 -> [Module] -- exports only of these modules
624 -> IO ()
625 setContext sess@(Session ref) toplev_mods export_mods = do
626 hsc_env <- readIORef ref
627 let old_ic = hsc_IC hsc_env
628 hpt = hsc_HPT hsc_env
629 --
630 export_env <- mkExportEnv hsc_env export_mods
631 toplev_envs <- mapM (mkTopLevEnv hpt) toplev_mods
632 let all_env = foldr plusGlobalRdrEnv export_env toplev_envs
633 writeIORef ref hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplev_mods,
634 ic_exports = export_mods,
635 ic_rn_gbl_env = all_env }}
636
637 -- Make a GlobalRdrEnv based on the exports of the modules only.
638 mkExportEnv :: HscEnv -> [Module] -> IO GlobalRdrEnv
639 mkExportEnv hsc_env mods = do
640 stuff <- mapM (getModuleExports hsc_env) mods
641 let
642 (_msgs, mb_name_sets) = unzip stuff
643 gres = [ nameSetToGlobalRdrEnv (availsToNameSet avails) (moduleName mod)
644 | (Just avails, mod) <- zip mb_name_sets mods ]
645 --
646 return $! foldr plusGlobalRdrEnv emptyGlobalRdrEnv gres
647
648 nameSetToGlobalRdrEnv :: NameSet -> ModuleName -> GlobalRdrEnv
649 nameSetToGlobalRdrEnv names mod =
650 mkGlobalRdrEnv [ GRE { gre_name = name, gre_par = NoParent, gre_prov = vanillaProv mod }
651 | name <- nameSetToList names ]
652
653 vanillaProv :: ModuleName -> Provenance
654 -- We're building a GlobalRdrEnv as if the user imported
655 -- all the specified modules into the global interactive module
656 vanillaProv mod_name = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}]
657 where
658 decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name,
659 is_qual = False,
660 is_dloc = srcLocSpan interactiveSrcLoc }
661
662 mkTopLevEnv :: HomePackageTable -> Module -> IO GlobalRdrEnv
663 mkTopLevEnv hpt modl
664 = case lookupUFM hpt (moduleName modl) of
665 Nothing -> throwDyn (ProgramError ("mkTopLevEnv: not a home module " ++
666 showSDoc (ppr modl)))
667 Just details ->
668 case mi_globals (hm_iface details) of
669 Nothing ->
670 throwDyn (ProgramError ("mkTopLevEnv: not interpreted "
671 ++ showSDoc (ppr modl)))
672 Just env -> return env
673
674 -- | Get the interactive evaluation context, consisting of a pair of the
675 -- set of modules from which we take the full top-level scope, and the set
676 -- of modules from which we take just the exports respectively.
677 getContext :: Session -> IO ([Module],[Module])
678 getContext s = withSession s (\HscEnv{ hsc_IC=ic } ->
679 return (ic_toplev_scope ic, ic_exports ic))
680
681 -- | Returns 'True' if the specified module is interpreted, and hence has
682 -- its full top-level scope available.
683 moduleIsInterpreted :: Session -> Module -> IO Bool
684 moduleIsInterpreted s modl = withSession s $ \h ->
685 if modulePackageId modl /= thisPackage (hsc_dflags h)
686 then return False
687 else case lookupUFM (hsc_HPT h) (moduleName modl) of
688 Just details -> return (isJust (mi_globals (hm_iface details)))
689 _not_a_home_module -> return False
690
691 -- | Looks up an identifier in the current interactive context (for :info)
692 getInfo :: Session -> Name -> IO (Maybe (TyThing,Fixity,[Instance]))
693 getInfo s name = withSession s $ \hsc_env -> tcRnGetInfo hsc_env name
694
695 -- | Returns all names in scope in the current interactive context
696 getNamesInScope :: Session -> IO [Name]
697 getNamesInScope s = withSession s $ \hsc_env -> do
698 return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env))))
699
700 getRdrNamesInScope :: Session -> IO [RdrName]
701 getRdrNamesInScope s = withSession s $ \hsc_env -> do
702 let
703 ic = hsc_IC hsc_env
704 gbl_rdrenv = ic_rn_gbl_env ic
705 ids = ic_tmp_ids ic
706 gbl_names = concat (map greToRdrNames (globalRdrEnvElts gbl_rdrenv))
707 lcl_names = map (mkRdrUnqual.nameOccName.idName) ids
708 --
709 return (gbl_names ++ lcl_names)
710
711
712 -- ToDo: move to RdrName
713 greToRdrNames :: GlobalRdrElt -> [RdrName]
714 greToRdrNames GRE{ gre_name = name, gre_prov = prov }
715 = case prov of
716 LocalDef -> [unqual]
717 Imported specs -> concat (map do_spec (map is_decl specs))
718 where
719 occ = nameOccName name
720 unqual = Unqual occ
721 do_spec decl_spec
722 | is_qual decl_spec = [qual]
723 | otherwise = [unqual,qual]
724 where qual = Qual (is_as decl_spec) occ
725
726 -- | Parses a string as an identifier, and returns the list of 'Name's that
727 -- the identifier can refer to in the current interactive context.
728 parseName :: Session -> String -> IO [Name]
729 parseName s str = withSession s $ \hsc_env -> do
730 maybe_rdr_name <- hscParseIdentifier (hsc_dflags hsc_env) str
731 case maybe_rdr_name of
732 Nothing -> return []
733 Just (L _ rdr_name) -> do
734 mb_names <- tcRnLookupRdrName hsc_env rdr_name
735 case mb_names of
736 Nothing -> return []
737 Just ns -> return ns
738 -- ToDo: should return error messages
739
740 -- | Returns the 'TyThing' for a 'Name'. The 'Name' may refer to any
741 -- entity known to GHC, including 'Name's defined using 'runStmt'.
742 lookupName :: Session -> Name -> IO (Maybe TyThing)
743 lookupName s name = withSession s $ \hsc_env -> tcRnLookupName hsc_env name
744
745 -- -----------------------------------------------------------------------------
746 -- Getting the type of an expression
747
748 -- | Get the type of an expression
749 exprType :: Session -> String -> IO (Maybe Type)
750 exprType s expr = withSession s $ \hsc_env -> do
751 maybe_stuff <- hscTcExpr hsc_env expr
752 case maybe_stuff of
753 Nothing -> return Nothing
754 Just ty -> return (Just tidy_ty)
755 where
756 tidy_ty = tidyType emptyTidyEnv ty
757
758 -- -----------------------------------------------------------------------------
759 -- Getting the kind of a type
760
761 -- | Get the kind of a type
762 typeKind :: Session -> String -> IO (Maybe Kind)
763 typeKind s str = withSession s $ \hsc_env -> do
764 maybe_stuff <- hscKcType hsc_env str
765 case maybe_stuff of
766 Nothing -> return Nothing
767 Just kind -> return (Just kind)
768
769 -----------------------------------------------------------------------------
770 -- cmCompileExpr: compile an expression and deliver an HValue
771
772 compileExpr :: Session -> String -> IO (Maybe HValue)
773 compileExpr s expr = withSession s $ \hsc_env -> do
774 maybe_stuff <- hscStmt hsc_env ("let __cmCompileExpr = "++expr)
775 case maybe_stuff of
776 Nothing -> return Nothing
777 Just (ids, hval) -> do
778 -- Run it!
779 hvals <- (unsafeCoerce# hval) :: IO [HValue]
780
781 case (ids,hvals) of
782 ([n],[hv]) -> return (Just hv)
783 _ -> panic "compileExpr"
784
785 -- -----------------------------------------------------------------------------
786 -- Compile an expression into a dynamic
787
788 dynCompileExpr :: Session -> String -> IO (Maybe Dynamic)
789 dynCompileExpr ses expr = do
790 (full,exports) <- getContext ses
791 setContext ses full $
792 (mkModule
793 (stringToPackageId "base") (mkModuleName "Data.Dynamic")
794 ):exports
795 let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")"
796 res <- withSession ses (flip hscStmt stmt)
797 setContext ses full exports
798 case res of
799 Nothing -> return Nothing
800 Just (ids, hvals) -> do
801 vals <- (unsafeCoerce# hvals :: IO [Dynamic])
802 case (ids,vals) of
803 (_:[], v:[]) -> return (Just v)
804 _ -> panic "dynCompileExpr"
805
806 -----------------------------------------------------------------------------
807 -- show a module and it's source/object filenames
808
809 showModule :: Session -> ModSummary -> IO String
810 showModule s mod_summary = withSession s $ \hsc_env ->
811 isModuleInterpreted s mod_summary >>= \interpreted ->
812 return (showModMsg (hscTarget(hsc_dflags hsc_env)) interpreted mod_summary)
813
814 isModuleInterpreted :: Session -> ModSummary -> IO Bool
815 isModuleInterpreted s mod_summary = withSession s $ \hsc_env ->
816 case lookupUFM (hsc_HPT hsc_env) (ms_mod_name mod_summary) of
817 Nothing -> panic "missing linkable"
818 Just mod_info -> return (not obj_linkable)
819 where
820 obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info))
821
822 obtainTerm1 :: Session -> Bool -> Maybe Type -> a -> IO Term
823 obtainTerm1 sess force mb_ty x = withSession sess $ \hsc_env -> cvObtainTerm hsc_env force mb_ty (unsafeCoerce# x)
824
825 obtainTerm :: Session -> Bool -> Id -> IO Term
826 obtainTerm sess force id = withSession sess $ \hsc_env -> do
827 hv <- Linker.getHValue hsc_env (varName id)
828 cvObtainTerm hsc_env force (Just$ idType id) hv
829
830 #endif /* GHCI */