eliminate warnings
[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 thing
272 putMVar statusMVar (Complete res)))
273 (takeMVar statusMVar)
274
275 withInterruptsSentTo :: IO ThreadId -> IO r -> IO r
276 withInterruptsSentTo io get_result = do
277 ts <- takeMVar interruptTargetThread
278 child <- io
279 putMVar interruptTargetThread (child:ts)
280 get_result `finally` modifyMVar_ interruptTargetThread (return.tail)
281
282 -- This function sets up the interpreter for catching breakpoints, and
283 -- resets everything when the computation has stopped running. This
284 -- is a not-very-good way to ensure that only the interactive
285 -- evaluation should generate breakpoints.
286 withBreakAction step dflags breakMVar statusMVar io
287 = bracket setBreakAction resetBreakAction (\_ -> io)
288 where
289 setBreakAction = do
290 stablePtr <- newStablePtr onBreak
291 poke breakPointIOAction stablePtr
292 when (dopt Opt_BreakOnException dflags) $ poke exceptionFlag 1
293 when step $ setStepFlag
294 return stablePtr
295 -- Breaking on exceptions is not enabled by default, since it
296 -- might be a bit surprising. The exception flag is turned off
297 -- as soon as it is hit, or in resetBreakAction below.
298
299 onBreak is_exception info apStack = do
300 tid <- myThreadId
301 putMVar statusMVar (Break is_exception apStack info tid)
302 takeMVar breakMVar
303
304 resetBreakAction stablePtr = do
305 poke breakPointIOAction noBreakStablePtr
306 poke exceptionFlag 0
307 resetStepFlag
308 freeStablePtr stablePtr
309
310 noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction
311
312 noBreakAction False info apStack = putStrLn "*** Ignoring breakpoint"
313 noBreakAction True info apStack = return () -- exception: just continue
314
315 resume :: Session -> SingleStep -> IO RunResult
316 resume (Session ref) step
317 = do
318 hsc_env <- readIORef ref
319 let ic = hsc_IC hsc_env
320 resume = ic_resume ic
321
322 case resume of
323 [] -> throwDyn (ProgramError "not stopped at a breakpoint")
324 (r:rs) -> do
325 -- unbind the temporary locals by restoring the TypeEnv from
326 -- before the breakpoint, and drop this Resume from the
327 -- InteractiveContext.
328 let (resume_tmp_ids, resume_tyvars) = resumeBindings r
329 ic' = ic { ic_tmp_ids = resume_tmp_ids,
330 ic_tyvars = resume_tyvars,
331 ic_resume = rs }
332 writeIORef ref hsc_env{ hsc_IC = ic' }
333
334 -- remove any bindings created since the breakpoint from the
335 -- linker's environment
336 let new_names = map idName (filter (`notElem` resume_tmp_ids)
337 (ic_tmp_ids ic))
338 Linker.deleteFromLinkEnv new_names
339
340 when (isStep step) $ setStepFlag
341 case r of
342 Resume expr tid breakMVar statusMVar bindings
343 final_ids apStack info _ _ _ -> do
344 withBreakAction (isStep step) (hsc_dflags hsc_env)
345 breakMVar statusMVar $ do
346 status <- withInterruptsSentTo
347 (do putMVar breakMVar ()
348 -- this awakens the stopped thread...
349 return tid)
350 (takeMVar statusMVar)
351 -- and wait for the result
352 case step of
353 RunAndLogSteps ->
354 traceRunStatus expr ref bindings final_ids
355 breakMVar statusMVar status emptyHistory
356 _other ->
357 handleRunStatus expr ref bindings final_ids
358 breakMVar statusMVar status emptyHistory
359
360
361 back :: Session -> IO ([Name], Int, SrcSpan)
362 back = moveHist (+1)
363
364 forward :: Session -> IO ([Name], Int, SrcSpan)
365 forward = moveHist (subtract 1)
366
367 moveHist fn (Session ref) = do
368 hsc_env <- readIORef ref
369 case ic_resume (hsc_IC hsc_env) of
370 [] -> throwDyn (ProgramError "not stopped at a breakpoint")
371 (r:rs) -> do
372 let ix = resumeHistoryIx r
373 history = resumeHistory r
374 new_ix = fn ix
375 --
376 when (new_ix > length history) $
377 throwDyn (ProgramError "no more logged breakpoints")
378 when (new_ix < 0) $
379 throwDyn (ProgramError "already at the beginning of the history")
380
381 let
382 update_ic apStack mb_info = do
383 (hsc_env1, names, span) <- bindLocalsAtBreakpoint hsc_env
384 apStack mb_info
385 let ic = hsc_IC hsc_env1
386 r' = r { resumeHistoryIx = new_ix }
387 ic' = ic { ic_resume = r':rs }
388
389 writeIORef ref hsc_env1{ hsc_IC = ic' }
390
391 return (names, new_ix, span)
392
393 -- careful: we want apStack to be the AP_STACK itself, not a thunk
394 -- around it, hence the cases are carefully constructed below to
395 -- make this the case. ToDo: this is v. fragile, do something better.
396 if new_ix == 0
397 then case r of
398 Resume { resumeApStack = apStack,
399 resumeBreakInfo = mb_info } ->
400 update_ic apStack mb_info
401 else case history !! (new_ix - 1) of
402 History apStack info ->
403 update_ic apStack (Just info)
404
405 -- -----------------------------------------------------------------------------
406 -- After stopping at a breakpoint, add free variables to the environment
407
408 bindLocalsAtBreakpoint
409 :: HscEnv
410 -> HValue
411 -> Maybe BreakInfo
412 -> IO (HscEnv, [Name], SrcSpan)
413
414 -- Nothing case: we stopped when an exception was raised, not at a
415 -- breakpoint. We have no location information or local variables to
416 -- bind, all we can do is bind a local variable to the exception
417 -- value.
418 bindLocalsAtBreakpoint hsc_env apStack Nothing = do
419 let exn_fs = FSLIT("_exception")
420 exn_name = mkInternalName (getUnique exn_fs) (mkVarOccFS exn_fs) span
421 e_fs = FSLIT("e")
422 e_name = mkInternalName (getUnique e_fs) (mkTyVarOcc e_fs) span
423 e_tyvar = mkTcTyVar e_name liftedTypeKind (SkolemTv RuntimeUnkSkol)
424 exn_id = Id.mkGlobalId VanillaGlobal exn_name (mkTyVarTy e_tyvar)
425 vanillaIdInfo
426 new_tyvars = unitVarSet e_tyvar
427
428 ictxt0 = hsc_IC hsc_env
429 ictxt1 = extendInteractiveContext ictxt0 [exn_id] new_tyvars
430
431 span = mkGeneralSrcSpan FSLIT("<exception thrown>")
432 --
433 Linker.extendLinkEnv [(exn_name, unsafeCoerce# apStack)]
434 return (hsc_env{ hsc_IC = ictxt1 }, [exn_name], span)
435
436 -- Just case: we stopped at a breakpoint, we have information about the location
437 -- of the breakpoint and the free variables of the expression.
438 bindLocalsAtBreakpoint hsc_env apStack (Just info) = do
439
440 let
441 mod_name = moduleName (breakInfo_module info)
442 mod_details = fmap hm_details (lookupUFM (hsc_HPT hsc_env) mod_name)
443 breaks = md_modBreaks (expectJust "handlRunStatus" mod_details)
444 index = breakInfo_number info
445 vars = breakInfo_vars info
446 result_ty = breakInfo_resty info
447 occs = modBreaks_vars breaks ! index
448 span = modBreaks_locs breaks ! index
449
450 -- filter out any unboxed ids; we can't bind these at the prompt
451 let pointers = filter (\(id,_) -> isPointer id) vars
452 isPointer id | PtrRep <- idPrimRep id = True
453 | otherwise = False
454
455 let (ids, offsets) = unzip pointers
456
457 -- It might be that getIdValFromApStack fails, because the AP_STACK
458 -- has been accidentally evaluated, or something else has gone wrong.
459 -- So that we don't fall over in a heap when this happens, just don't
460 -- bind any free variables instead, and we emit a warning.
461 mb_hValues <- mapM (getIdValFromApStack apStack) offsets
462 let filtered_ids = [ id | (id, Just _) <- zip ids mb_hValues ]
463 when (any isNothing mb_hValues) $
464 debugTraceMsg (hsc_dflags hsc_env) 1 $
465 text "Warning: _result has been evaluated, some bindings have been lost"
466
467 new_ids <- zipWithM mkNewId occs filtered_ids
468 let names = map idName new_ids
469
470 -- make an Id for _result. We use the Unique of the FastString "_result";
471 -- we don't care about uniqueness here, because there will only be one
472 -- _result in scope at any time.
473 let result_fs = FSLIT("_result")
474 result_name = mkInternalName (getUnique result_fs)
475 (mkVarOccFS result_fs) span
476 result_id = Id.mkGlobalId VanillaGlobal result_name result_ty
477 vanillaIdInfo
478
479 -- for each Id we're about to bind in the local envt:
480 -- - skolemise the type variables in its type, so they can't
481 -- be randomly unified with other types. These type variables
482 -- can only be resolved by type reconstruction in RtClosureInspect
483 -- - tidy the type variables
484 -- - globalise the Id (Ids are supposed to be Global, apparently).
485 --
486 let all_ids | isPointer result_id = result_id : new_ids
487 | otherwise = new_ids
488 (id_tys, tyvarss) = mapAndUnzip (skolemiseTy.idType) all_ids
489 (_,tidy_tys) = tidyOpenTypes emptyTidyEnv id_tys
490 new_tyvars = unionVarSets tyvarss
491 final_ids = zipWith setIdType all_ids tidy_tys
492
493 let ictxt0 = hsc_IC hsc_env
494 ictxt1 = extendInteractiveContext ictxt0 final_ids new_tyvars
495
496 Linker.extendLinkEnv [ (name,hval) | (name, Just hval) <- zip names mb_hValues ]
497 Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)]
498 return (hsc_env{ hsc_IC = ictxt1 }, result_name:names, span)
499 where
500 mkNewId :: OccName -> Id -> IO Id
501 mkNewId occ id = do
502 let uniq = idUnique id
503 loc = nameSrcSpan (idName id)
504 name = mkInternalName uniq occ loc
505 ty = idType id
506 new_id = Id.mkGlobalId VanillaGlobal name ty (idInfo id)
507 return new_id
508
509 skolemiseTy :: Type -> (Type, TyVarSet)
510 skolemiseTy ty = (substTy subst ty, mkVarSet new_tyvars)
511 where env = mkVarEnv (zip tyvars new_tyvar_tys)
512 subst = mkTvSubst emptyInScopeSet env
513 tyvars = varSetElems (tyVarsOfType ty)
514 new_tyvars = map skolemiseTyVar tyvars
515 new_tyvar_tys = map mkTyVarTy new_tyvars
516
517 skolemiseTyVar :: TyVar -> TyVar
518 skolemiseTyVar tyvar = mkTcTyVar (tyVarName tyvar) (tyVarKind tyvar)
519 (SkolemTv RuntimeUnkSkol)
520
521 getIdValFromApStack :: HValue -> Int -> IO (Maybe HValue)
522 getIdValFromApStack apStack (I# stackDepth) = do
523 case getApStackVal# apStack (stackDepth +# 1#) of
524 -- The +1 is magic! I don't know where it comes
525 -- from, but this makes things line up. --SDM
526 (# ok, result #) ->
527 case ok of
528 0# -> return Nothing -- AP_STACK not found
529 _ -> return (Just (unsafeCoerce# result))
530
531 pushResume :: HscEnv -> Resume -> HscEnv
532 pushResume hsc_env resume = hsc_env { hsc_IC = ictxt1 }
533 where
534 ictxt0 = hsc_IC hsc_env
535 ictxt1 = ictxt0 { ic_resume = resume : ic_resume ictxt0 }
536
537 -- -----------------------------------------------------------------------------
538 -- Abandoning a resume context
539
540 abandon :: Session -> IO Bool
541 abandon (Session ref) = do
542 hsc_env <- readIORef ref
543 let ic = hsc_IC hsc_env
544 resume = ic_resume ic
545 case resume of
546 [] -> return False
547 r:rs -> do
548 writeIORef ref hsc_env{ hsc_IC = ic { ic_resume = rs } }
549 abandon_ r
550 return True
551
552 abandonAll :: Session -> IO Bool
553 abandonAll (Session ref) = do
554 hsc_env <- readIORef ref
555 let ic = hsc_IC hsc_env
556 resume = ic_resume ic
557 case resume of
558 [] -> return False
559 rs -> do
560 writeIORef ref hsc_env{ hsc_IC = ic { ic_resume = [] } }
561 mapM_ abandon_ rs
562 return True
563
564 -- when abandoning a computation we have to
565 -- (a) kill the thread with an async exception, so that the
566 -- computation itself is stopped, and
567 -- (b) fill in the MVar. This step is necessary because any
568 -- thunks that were under evaluation will now be updated
569 -- with the partial computation, which still ends in takeMVar,
570 -- so any attempt to evaluate one of these thunks will block
571 -- unless we fill in the MVar.
572 -- See test break010.
573 abandon_ :: Resume -> IO ()
574 abandon_ r = do
575 killThread (resumeThreadId r)
576 putMVar (resumeBreakMVar r) ()
577
578 -- -----------------------------------------------------------------------------
579 -- Bounded list, optimised for repeated cons
580
581 data BoundedList a = BL
582 {-# UNPACK #-} !Int -- length
583 {-# UNPACK #-} !Int -- bound
584 [a] -- left
585 [a] -- right, list is (left ++ reverse right)
586
587 nilBL :: Int -> BoundedList a
588 nilBL bound = BL 0 bound [] []
589
590 consBL a (BL len bound left right)
591 | len < bound = BL (len+1) bound (a:left) right
592 | null right = BL len bound [a] $! tail (reverse left)
593 | otherwise = BL len bound (a:left) $! tail right
594
595 toListBL (BL _ _ left right) = left ++ reverse right
596
597 -- lenBL (BL len _ _ _) = len
598
599 -- -----------------------------------------------------------------------------
600 -- | Set the interactive evaluation context.
601 --
602 -- Setting the context doesn't throw away any bindings; the bindings
603 -- we've built up in the InteractiveContext simply move to the new
604 -- module. They always shadow anything in scope in the current context.
605 setContext :: Session
606 -> [Module] -- entire top level scope of these modules
607 -> [Module] -- exports only of these modules
608 -> IO ()
609 setContext sess@(Session ref) toplev_mods export_mods = do
610 hsc_env <- readIORef ref
611 let old_ic = hsc_IC hsc_env
612 hpt = hsc_HPT hsc_env
613 --
614 export_env <- mkExportEnv hsc_env export_mods
615 toplev_envs <- mapM (mkTopLevEnv hpt) toplev_mods
616 let all_env = foldr plusGlobalRdrEnv export_env toplev_envs
617 writeIORef ref hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplev_mods,
618 ic_exports = export_mods,
619 ic_rn_gbl_env = all_env }}
620
621 -- Make a GlobalRdrEnv based on the exports of the modules only.
622 mkExportEnv :: HscEnv -> [Module] -> IO GlobalRdrEnv
623 mkExportEnv hsc_env mods = do
624 stuff <- mapM (getModuleExports hsc_env) mods
625 let
626 (_msgs, mb_name_sets) = unzip stuff
627 gres = [ nameSetToGlobalRdrEnv (availsToNameSet avails) (moduleName mod)
628 | (Just avails, mod) <- zip mb_name_sets mods ]
629 --
630 return $! foldr plusGlobalRdrEnv emptyGlobalRdrEnv gres
631
632 nameSetToGlobalRdrEnv :: NameSet -> ModuleName -> GlobalRdrEnv
633 nameSetToGlobalRdrEnv names mod =
634 mkGlobalRdrEnv [ GRE { gre_name = name, gre_par = NoParent, gre_prov = vanillaProv mod }
635 | name <- nameSetToList names ]
636
637 vanillaProv :: ModuleName -> Provenance
638 -- We're building a GlobalRdrEnv as if the user imported
639 -- all the specified modules into the global interactive module
640 vanillaProv mod_name = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}]
641 where
642 decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name,
643 is_qual = False,
644 is_dloc = srcLocSpan interactiveSrcLoc }
645
646 mkTopLevEnv :: HomePackageTable -> Module -> IO GlobalRdrEnv
647 mkTopLevEnv hpt modl
648 = case lookupUFM hpt (moduleName modl) of
649 Nothing -> throwDyn (ProgramError ("mkTopLevEnv: not a home module " ++
650 showSDoc (ppr modl)))
651 Just details ->
652 case mi_globals (hm_iface details) of
653 Nothing ->
654 throwDyn (ProgramError ("mkTopLevEnv: not interpreted "
655 ++ showSDoc (ppr modl)))
656 Just env -> return env
657
658 -- | Get the interactive evaluation context, consisting of a pair of the
659 -- set of modules from which we take the full top-level scope, and the set
660 -- of modules from which we take just the exports respectively.
661 getContext :: Session -> IO ([Module],[Module])
662 getContext s = withSession s (\HscEnv{ hsc_IC=ic } ->
663 return (ic_toplev_scope ic, ic_exports ic))
664
665 -- | Returns 'True' if the specified module is interpreted, and hence has
666 -- its full top-level scope available.
667 moduleIsInterpreted :: Session -> Module -> IO Bool
668 moduleIsInterpreted s modl = withSession s $ \h ->
669 if modulePackageId modl /= thisPackage (hsc_dflags h)
670 then return False
671 else case lookupUFM (hsc_HPT h) (moduleName modl) of
672 Just details -> return (isJust (mi_globals (hm_iface details)))
673 _not_a_home_module -> return False
674
675 -- | Looks up an identifier in the current interactive context (for :info)
676 getInfo :: Session -> Name -> IO (Maybe (TyThing,Fixity,[Instance]))
677 getInfo s name = withSession s $ \hsc_env -> tcRnGetInfo hsc_env name
678
679 -- | Returns all names in scope in the current interactive context
680 getNamesInScope :: Session -> IO [Name]
681 getNamesInScope s = withSession s $ \hsc_env -> do
682 return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env))))
683
684 getRdrNamesInScope :: Session -> IO [RdrName]
685 getRdrNamesInScope s = withSession s $ \hsc_env -> do
686 let
687 ic = hsc_IC hsc_env
688 gbl_rdrenv = ic_rn_gbl_env ic
689 ids = ic_tmp_ids ic
690 gbl_names = concat (map greToRdrNames (globalRdrEnvElts gbl_rdrenv))
691 lcl_names = map (mkRdrUnqual.nameOccName.idName) ids
692 --
693 return (gbl_names ++ lcl_names)
694
695
696 -- ToDo: move to RdrName
697 greToRdrNames :: GlobalRdrElt -> [RdrName]
698 greToRdrNames GRE{ gre_name = name, gre_prov = prov }
699 = case prov of
700 LocalDef -> [unqual]
701 Imported specs -> concat (map do_spec (map is_decl specs))
702 where
703 occ = nameOccName name
704 unqual = Unqual occ
705 do_spec decl_spec
706 | is_qual decl_spec = [qual]
707 | otherwise = [unqual,qual]
708 where qual = Qual (is_as decl_spec) occ
709
710 -- | Parses a string as an identifier, and returns the list of 'Name's that
711 -- the identifier can refer to in the current interactive context.
712 parseName :: Session -> String -> IO [Name]
713 parseName s str = withSession s $ \hsc_env -> do
714 maybe_rdr_name <- hscParseIdentifier (hsc_dflags hsc_env) str
715 case maybe_rdr_name of
716 Nothing -> return []
717 Just (L _ rdr_name) -> do
718 mb_names <- tcRnLookupRdrName hsc_env rdr_name
719 case mb_names of
720 Nothing -> return []
721 Just ns -> return ns
722 -- ToDo: should return error messages
723
724 -- | Returns the 'TyThing' for a 'Name'. The 'Name' may refer to any
725 -- entity known to GHC, including 'Name's defined using 'runStmt'.
726 lookupName :: Session -> Name -> IO (Maybe TyThing)
727 lookupName s name = withSession s $ \hsc_env -> tcRnLookupName hsc_env name
728
729 -- -----------------------------------------------------------------------------
730 -- Getting the type of an expression
731
732 -- | Get the type of an expression
733 exprType :: Session -> String -> IO (Maybe Type)
734 exprType s expr = withSession s $ \hsc_env -> do
735 maybe_stuff <- hscTcExpr hsc_env expr
736 case maybe_stuff of
737 Nothing -> return Nothing
738 Just ty -> return (Just tidy_ty)
739 where
740 tidy_ty = tidyType emptyTidyEnv ty
741
742 -- -----------------------------------------------------------------------------
743 -- Getting the kind of a type
744
745 -- | Get the kind of a type
746 typeKind :: Session -> String -> IO (Maybe Kind)
747 typeKind s str = withSession s $ \hsc_env -> do
748 maybe_stuff <- hscKcType hsc_env str
749 case maybe_stuff of
750 Nothing -> return Nothing
751 Just kind -> return (Just kind)
752
753 -----------------------------------------------------------------------------
754 -- cmCompileExpr: compile an expression and deliver an HValue
755
756 compileExpr :: Session -> String -> IO (Maybe HValue)
757 compileExpr s expr = withSession s $ \hsc_env -> do
758 maybe_stuff <- hscStmt hsc_env ("let __cmCompileExpr = "++expr)
759 case maybe_stuff of
760 Nothing -> return Nothing
761 Just (ids, hval) -> do
762 -- Run it!
763 hvals <- (unsafeCoerce# hval) :: IO [HValue]
764
765 case (ids,hvals) of
766 ([n],[hv]) -> return (Just hv)
767 _ -> panic "compileExpr"
768
769 -- -----------------------------------------------------------------------------
770 -- Compile an expression into a dynamic
771
772 dynCompileExpr :: Session -> String -> IO (Maybe Dynamic)
773 dynCompileExpr ses expr = do
774 (full,exports) <- getContext ses
775 setContext ses full $
776 (mkModule
777 (stringToPackageId "base") (mkModuleName "Data.Dynamic")
778 ):exports
779 let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")"
780 res <- withSession ses (flip hscStmt stmt)
781 setContext ses full exports
782 case res of
783 Nothing -> return Nothing
784 Just (ids, hvals) -> do
785 vals <- (unsafeCoerce# hvals :: IO [Dynamic])
786 case (ids,vals) of
787 (_:[], v:[]) -> return (Just v)
788 _ -> panic "dynCompileExpr"
789
790 -----------------------------------------------------------------------------
791 -- show a module and it's source/object filenames
792
793 showModule :: Session -> ModSummary -> IO String
794 showModule s mod_summary = withSession s $ \hsc_env ->
795 isModuleInterpreted s mod_summary >>= \interpreted ->
796 return (showModMsg (hscTarget(hsc_dflags hsc_env)) interpreted mod_summary)
797
798 isModuleInterpreted :: Session -> ModSummary -> IO Bool
799 isModuleInterpreted s mod_summary = withSession s $ \hsc_env ->
800 case lookupUFM (hsc_HPT hsc_env) (ms_mod_name mod_summary) of
801 Nothing -> panic "missing linkable"
802 Just mod_info -> return (not obj_linkable)
803 where
804 obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info))
805
806 obtainTerm1 :: Session -> Bool -> Maybe Type -> a -> IO Term
807 obtainTerm1 sess force mb_ty x = withSession sess $ \hsc_env -> cvObtainTerm hsc_env force mb_ty (unsafeCoerce# x)
808
809 obtainTerm :: Session -> Bool -> Id -> IO Term
810 obtainTerm sess force id = withSession sess $ \hsc_env -> do
811 hv <- Linker.getHValue hsc_env (varName id)
812 cvObtainTerm hsc_env force (Just$ idType id) hv
813
814 #endif /* GHCI */