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