b56d8d61e0bd60479df48a580c2093ff253cafef
[ghc.git] / compiler / main / InteractiveEval.hs
1 {-# LANGUAGE CPP, MagicHash, NondecreasingIndentation, UnboxedTuples,
2 RecordWildCards, BangPatterns #-}
3
4 -- -----------------------------------------------------------------------------
5 --
6 -- (c) The University of Glasgow, 2005-2007
7 --
8 -- Running statements interactively
9 --
10 -- -----------------------------------------------------------------------------
11
12 module InteractiveEval (
13 Resume(..), History(..),
14 execStmt, ExecOptions(..), execOptions, ExecResult(..), resumeExec,
15 runDecls, runDeclsWithLocation,
16 isStmt, hasImport, isImport, isDecl,
17 parseImportDecl, SingleStep(..),
18 abandon, abandonAll,
19 getResumeContext,
20 getHistorySpan,
21 getModBreaks,
22 getHistoryModule,
23 back, forward,
24 setContext, getContext,
25 availsToGlobalRdrEnv,
26 getNamesInScope,
27 getRdrNamesInScope,
28 moduleIsInterpreted,
29 getInfo,
30 exprType,
31 typeKind,
32 parseName,
33 showModule,
34 moduleIsBootOrNotObjectLinkable,
35 parseExpr, compileParsedExpr,
36 compileExpr, dynCompileExpr,
37 compileExprRemote, compileParsedExprRemote,
38 Term(..), obtainTermFromId, obtainTermFromVal, reconstructType
39 ) where
40
41 #include "HsVersions.h"
42
43 import InteractiveEvalTypes
44
45 import GHCi
46 import GHCi.Message
47 import GHCi.RemoteTypes
48 import GhcMonad
49 import HscMain
50 import HsSyn
51 import HscTypes
52 import InstEnv
53 import IfaceEnv ( newInteractiveBinder )
54 import FamInstEnv ( FamInst )
55 import CoreFVs ( orphNamesOfFamInst )
56 import TyCon
57 import Type hiding( typeKind )
58 import RepType
59 import TcType hiding( typeKind )
60 import Var
61 import Id
62 import Name hiding ( varName )
63 import NameSet
64 import Avail
65 import RdrName
66 import VarEnv
67 import ByteCodeTypes
68 import Linker
69 import DynFlags
70 import Unique
71 import UniqSupply
72 import MonadUtils
73 import Module
74 import PrelNames ( toDynName, pretendNameIsInScope )
75 import Panic
76 import Maybes
77 import ErrUtils
78 import SrcLoc
79 import RtClosureInspect
80 import Outputable
81 import FastString
82 import Bag
83 import qualified Lexer (P (..), ParseResult(..), unP, mkPState)
84 import qualified Parser (parseStmt, parseModule, parseDeclaration, parseImport)
85
86 import System.Directory
87 import Data.Dynamic
88 import Data.Either
89 import qualified Data.IntMap as IntMap
90 import Data.List (find,intercalate)
91 import StringBuffer (stringToStringBuffer)
92 import Control.Monad
93 import GHC.Exts
94 import Data.Array
95 import Exception
96
97 -- -----------------------------------------------------------------------------
98 -- running a statement interactively
99
100 getResumeContext :: GhcMonad m => m [Resume]
101 getResumeContext = withSession (return . ic_resume . hsc_IC)
102
103 mkHistory :: HscEnv -> ForeignHValue -> BreakInfo -> History
104 mkHistory hsc_env hval bi = History hval bi (findEnclosingDecls hsc_env bi)
105
106 getHistoryModule :: History -> Module
107 getHistoryModule = breakInfo_module . historyBreakInfo
108
109 getHistorySpan :: HscEnv -> History -> SrcSpan
110 getHistorySpan hsc_env History{..} =
111 let BreakInfo{..} = historyBreakInfo in
112 case lookupHpt (hsc_HPT hsc_env) (moduleName breakInfo_module) of
113 Just hmi -> modBreaks_locs (getModBreaks hmi) ! breakInfo_number
114 _ -> panic "getHistorySpan"
115
116 getModBreaks :: HomeModInfo -> ModBreaks
117 getModBreaks hmi
118 | Just linkable <- hm_linkable hmi,
119 [BCOs cbc _] <- linkableUnlinked linkable
120 = fromMaybe emptyModBreaks (bc_breaks cbc)
121 | otherwise
122 = emptyModBreaks -- probably object code
123
124 {- | Finds the enclosing top level function name -}
125 -- ToDo: a better way to do this would be to keep hold of the decl_path computed
126 -- by the coverage pass, which gives the list of lexically-enclosing bindings
127 -- for each tick.
128 findEnclosingDecls :: HscEnv -> BreakInfo -> [String]
129 findEnclosingDecls hsc_env (BreakInfo modl ix) =
130 let hmi = expectJust "findEnclosingDecls" $
131 lookupHpt (hsc_HPT hsc_env) (moduleName modl)
132 mb = getModBreaks hmi
133 in modBreaks_decls mb ! ix
134
135 -- | Update fixity environment in the current interactive context.
136 updateFixityEnv :: GhcMonad m => FixityEnv -> m ()
137 updateFixityEnv fix_env = do
138 hsc_env <- getSession
139 let ic = hsc_IC hsc_env
140 setSession $ hsc_env { hsc_IC = ic { ic_fix_env = fix_env } }
141
142 -- -----------------------------------------------------------------------------
143 -- execStmt
144
145 -- | default ExecOptions
146 execOptions :: ExecOptions
147 execOptions = ExecOptions
148 { execSingleStep = RunToCompletion
149 , execSourceFile = "<interactive>"
150 , execLineNumber = 1
151 , execWrap = EvalThis -- just run the statement, don't wrap it in anything
152 }
153
154 -- | Run a statement in the current interactive context.
155 execStmt
156 :: GhcMonad m
157 => String -- ^ a statement (bind or expression)
158 -> ExecOptions
159 -> m ExecResult
160 execStmt stmt ExecOptions{..} = do
161 hsc_env <- getSession
162
163 -- Turn off -fwarn-unused-local-binds when running a statement, to hide
164 -- warnings about the implicit bindings we introduce.
165 let ic = hsc_IC hsc_env -- use the interactive dflags
166 idflags' = ic_dflags ic `wopt_unset` Opt_WarnUnusedLocalBinds
167 hsc_env' = hsc_env{ hsc_IC = ic{ ic_dflags = idflags' } }
168
169 -- compile to value (IO [HValue]), don't run
170 r <- liftIO $ hscStmtWithLocation hsc_env' stmt
171 execSourceFile execLineNumber
172
173 case r of
174 -- empty statement / comment
175 Nothing -> return (ExecComplete (Right []) 0)
176
177 Just (ids, hval, fix_env) -> do
178 updateFixityEnv fix_env
179
180 status <-
181 withVirtualCWD $
182 liftIO $
183 evalStmt hsc_env' (isStep execSingleStep) (execWrap hval)
184
185 let ic = hsc_IC hsc_env
186 bindings = (ic_tythings ic, ic_rn_gbl_env ic)
187
188 size = ghciHistSize idflags'
189
190 handleRunStatus execSingleStep stmt bindings ids
191 status (emptyHistory size)
192
193
194 runDecls :: GhcMonad m => String -> m [Name]
195 runDecls = runDeclsWithLocation "<interactive>" 1
196
197 -- | Run some declarations and return any user-visible names that were brought
198 -- into scope.
199 runDeclsWithLocation :: GhcMonad m => String -> Int -> String -> m [Name]
200 runDeclsWithLocation source linenumber expr =
201 do
202 hsc_env <- getSession
203 (tyThings, ic) <- liftIO $ hscDeclsWithLocation hsc_env expr source linenumber
204
205 setSession $ hsc_env { hsc_IC = ic }
206 hsc_env <- getSession
207 hsc_env' <- liftIO $ rttiEnvironment hsc_env
208 setSession hsc_env'
209 return $ filter (not . isDerivedOccName . nameOccName)
210 -- For this filter, see Note [What to show to users]
211 $ map getName tyThings
212
213 {- Note [What to show to users]
214 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
215 We don't want to display internally-generated bindings to users.
216 Things like the coercion axiom for newtypes. These bindings all get
217 OccNames that users can't write, to avoid the possiblity of name
218 clashes (in linker symbols). That gives a convenient way to suppress
219 them. The relevant predicate is OccName.isDerivedOccName.
220 See Trac #11051 for more background and examples.
221 -}
222
223 withVirtualCWD :: GhcMonad m => m a -> m a
224 withVirtualCWD m = do
225 hsc_env <- getSession
226
227 -- a virtual CWD is only necessary when we're running interpreted code in
228 -- the same process as the compiler.
229 if gopt Opt_ExternalInterpreter (hsc_dflags hsc_env) then m else do
230
231 let ic = hsc_IC hsc_env
232 let set_cwd = do
233 dir <- liftIO $ getCurrentDirectory
234 case ic_cwd ic of
235 Just dir -> liftIO $ setCurrentDirectory dir
236 Nothing -> return ()
237 return dir
238
239 reset_cwd orig_dir = do
240 virt_dir <- liftIO $ getCurrentDirectory
241 hsc_env <- getSession
242 let old_IC = hsc_IC hsc_env
243 setSession hsc_env{ hsc_IC = old_IC{ ic_cwd = Just virt_dir } }
244 liftIO $ setCurrentDirectory orig_dir
245
246 gbracket set_cwd reset_cwd $ \_ -> m
247
248 parseImportDecl :: GhcMonad m => String -> m (ImportDecl RdrName)
249 parseImportDecl expr = withSession $ \hsc_env -> liftIO $ hscImport hsc_env expr
250
251 emptyHistory :: Int -> BoundedList History
252 emptyHistory size = nilBL size
253
254 handleRunStatus :: GhcMonad m
255 => SingleStep -> String-> ([TyThing],GlobalRdrEnv) -> [Id]
256 -> EvalStatus_ [ForeignHValue] [HValueRef]
257 -> BoundedList History
258 -> m ExecResult
259
260 handleRunStatus step expr bindings final_ids status history
261 | RunAndLogSteps <- step = tracing
262 | otherwise = not_tracing
263 where
264 tracing
265 | EvalBreak is_exception apStack_ref ix mod_uniq resume_ctxt _ccs <- status
266 , not is_exception
267 = do
268 hsc_env <- getSession
269 let hmi = expectJust "handleRunStatus" $
270 lookupHptDirectly (hsc_HPT hsc_env)
271 (mkUniqueGrimily mod_uniq)
272 modl = mi_module (hm_iface hmi)
273 breaks = getModBreaks hmi
274
275 b <- liftIO $
276 breakpointStatus hsc_env (modBreaks_flags breaks) ix
277 if b
278 then not_tracing
279 -- This breakpoint is explicitly enabled; we want to stop
280 -- instead of just logging it.
281 else do
282 apStack_fhv <- liftIO $ mkFinalizedHValue hsc_env apStack_ref
283 let bi = BreakInfo modl ix
284 !history' = mkHistory hsc_env apStack_fhv bi `consBL` history
285 -- history is strict, otherwise our BoundedList is pointless.
286 fhv <- liftIO $ mkFinalizedHValue hsc_env resume_ctxt
287 status <- liftIO $ GHCi.resumeStmt hsc_env True fhv
288 handleRunStatus RunAndLogSteps expr bindings final_ids
289 status history'
290 | otherwise
291 = not_tracing
292
293 not_tracing
294 -- Hit a breakpoint
295 | EvalBreak is_exception apStack_ref ix mod_uniq resume_ctxt ccs <- status
296 = do
297 hsc_env <- getSession
298 resume_ctxt_fhv <- liftIO $ mkFinalizedHValue hsc_env resume_ctxt
299 apStack_fhv <- liftIO $ mkFinalizedHValue hsc_env apStack_ref
300 let hmi = expectJust "handleRunStatus" $
301 lookupHptDirectly (hsc_HPT hsc_env)
302 (mkUniqueGrimily mod_uniq)
303 modl = mi_module (hm_iface hmi)
304 bp | is_exception = Nothing
305 | otherwise = Just (BreakInfo modl ix)
306 (hsc_env1, names, span, decl) <- liftIO $
307 bindLocalsAtBreakpoint hsc_env apStack_fhv bp
308 let
309 resume = Resume
310 { resumeStmt = expr, resumeContext = resume_ctxt_fhv
311 , resumeBindings = bindings, resumeFinalIds = final_ids
312 , resumeApStack = apStack_fhv
313 , resumeBreakInfo = bp
314 , resumeSpan = span, resumeHistory = toListBL history
315 , resumeDecl = decl
316 , resumeCCS = ccs
317 , resumeHistoryIx = 0 }
318 hsc_env2 = pushResume hsc_env1 resume
319
320 setSession hsc_env2
321 return (ExecBreak names bp)
322
323 -- Completed successfully
324 | EvalComplete allocs (EvalSuccess hvals) <- status
325 = do hsc_env <- getSession
326 let final_ic = extendInteractiveContextWithIds (hsc_IC hsc_env) final_ids
327 final_names = map getName final_ids
328 liftIO $ Linker.extendLinkEnv (zip final_names hvals)
329 hsc_env' <- liftIO $ rttiEnvironment hsc_env{hsc_IC=final_ic}
330 setSession hsc_env'
331 return (ExecComplete (Right final_names) allocs)
332
333 -- Completed with an exception
334 | EvalComplete alloc (EvalException e) <- status
335 = return (ExecComplete (Left (fromSerializableException e)) alloc)
336
337 | otherwise
338 = panic "not_tracing" -- actually exhaustive, but GHC can't tell
339
340
341 resumeExec :: GhcMonad m => (SrcSpan->Bool) -> SingleStep -> m ExecResult
342 resumeExec canLogSpan step
343 = do
344 hsc_env <- getSession
345 let ic = hsc_IC hsc_env
346 resume = ic_resume ic
347
348 case resume of
349 [] -> liftIO $
350 throwGhcExceptionIO (ProgramError "not stopped at a breakpoint")
351 (r:rs) -> do
352 -- unbind the temporary locals by restoring the TypeEnv from
353 -- before the breakpoint, and drop this Resume from the
354 -- InteractiveContext.
355 let (resume_tmp_te,resume_rdr_env) = resumeBindings r
356 ic' = ic { ic_tythings = resume_tmp_te,
357 ic_rn_gbl_env = resume_rdr_env,
358 ic_resume = rs }
359 setSession hsc_env{ hsc_IC = ic' }
360
361 -- remove any bindings created since the breakpoint from the
362 -- linker's environment
363 let old_names = map getName resume_tmp_te
364 new_names = [ n | thing <- ic_tythings ic
365 , let n = getName thing
366 , not (n `elem` old_names) ]
367 liftIO $ Linker.deleteFromLinkEnv new_names
368
369 case r of
370 Resume { resumeStmt = expr, resumeContext = fhv
371 , resumeBindings = bindings, resumeFinalIds = final_ids
372 , resumeApStack = apStack, resumeBreakInfo = mb_brkpt
373 , resumeSpan = span
374 , resumeHistory = hist } -> do
375 withVirtualCWD $ do
376 status <- liftIO $ GHCi.resumeStmt hsc_env (isStep step) fhv
377 let prevHistoryLst = fromListBL 50 hist
378 hist' = case mb_brkpt of
379 Nothing -> prevHistoryLst
380 Just bi
381 | not $canLogSpan span -> prevHistoryLst
382 | otherwise -> mkHistory hsc_env apStack bi `consBL`
383 fromListBL 50 hist
384 handleRunStatus step expr bindings final_ids status hist'
385
386 back :: GhcMonad m => Int -> m ([Name], Int, SrcSpan, String)
387 back n = moveHist (+n)
388
389 forward :: GhcMonad m => Int -> m ([Name], Int, SrcSpan, String)
390 forward n = moveHist (subtract n)
391
392 moveHist :: GhcMonad m => (Int -> Int) -> m ([Name], Int, SrcSpan, String)
393 moveHist fn = do
394 hsc_env <- getSession
395 case ic_resume (hsc_IC hsc_env) of
396 [] -> liftIO $
397 throwGhcExceptionIO (ProgramError "not stopped at a breakpoint")
398 (r:rs) -> do
399 let ix = resumeHistoryIx r
400 history = resumeHistory r
401 new_ix = fn ix
402 --
403 when (new_ix > length history) $ liftIO $
404 throwGhcExceptionIO (ProgramError "no more logged breakpoints")
405 when (new_ix < 0) $ liftIO $
406 throwGhcExceptionIO (ProgramError "already at the beginning of the history")
407
408 let
409 update_ic apStack mb_info = do
410 (hsc_env1, names, span, decl) <-
411 liftIO $ bindLocalsAtBreakpoint hsc_env apStack mb_info
412 let ic = hsc_IC hsc_env1
413 r' = r { resumeHistoryIx = new_ix }
414 ic' = ic { ic_resume = r':rs }
415
416 setSession hsc_env1{ hsc_IC = ic' }
417
418 return (names, new_ix, span, decl)
419
420 -- careful: we want apStack to be the AP_STACK itself, not a thunk
421 -- around it, hence the cases are carefully constructed below to
422 -- make this the case. ToDo: this is v. fragile, do something better.
423 if new_ix == 0
424 then case r of
425 Resume { resumeApStack = apStack,
426 resumeBreakInfo = mb_brkpt } ->
427 update_ic apStack mb_brkpt
428 else case history !! (new_ix - 1) of
429 History{..} ->
430 update_ic historyApStack (Just historyBreakInfo)
431
432
433 -- -----------------------------------------------------------------------------
434 -- After stopping at a breakpoint, add free variables to the environment
435
436 result_fs :: FastString
437 result_fs = fsLit "_result"
438
439 bindLocalsAtBreakpoint
440 :: HscEnv
441 -> ForeignHValue
442 -> Maybe BreakInfo
443 -> IO (HscEnv, [Name], SrcSpan, String)
444
445 -- Nothing case: we stopped when an exception was raised, not at a
446 -- breakpoint. We have no location information or local variables to
447 -- bind, all we can do is bind a local variable to the exception
448 -- value.
449 bindLocalsAtBreakpoint hsc_env apStack Nothing = do
450 let exn_occ = mkVarOccFS (fsLit "_exception")
451 span = mkGeneralSrcSpan (fsLit "<unknown>")
452 exn_name <- newInteractiveBinder hsc_env exn_occ span
453
454 let e_fs = fsLit "e"
455 e_name = mkInternalName (getUnique e_fs) (mkTyVarOccFS e_fs) span
456 e_tyvar = mkRuntimeUnkTyVar e_name liftedTypeKind
457 exn_id = Id.mkVanillaGlobal exn_name (mkTyVarTy e_tyvar)
458
459 ictxt0 = hsc_IC hsc_env
460 ictxt1 = extendInteractiveContextWithIds ictxt0 [exn_id]
461 --
462 Linker.extendLinkEnv [(exn_name, apStack)]
463 return (hsc_env{ hsc_IC = ictxt1 }, [exn_name], span, "<exception thrown>")
464
465 -- Just case: we stopped at a breakpoint, we have information about the location
466 -- of the breakpoint and the free variables of the expression.
467 bindLocalsAtBreakpoint hsc_env apStack_fhv (Just BreakInfo{..}) = do
468 let
469 hmi = expectJust "bindLocalsAtBreakpoint" $
470 lookupHpt (hsc_HPT hsc_env) (moduleName breakInfo_module)
471 breaks = getModBreaks hmi
472 info = expectJust "bindLocalsAtBreakpoint2" $
473 IntMap.lookup breakInfo_number (modBreaks_breakInfo breaks)
474 vars = cgb_vars info
475 result_ty = cgb_resty info
476 occs = modBreaks_vars breaks ! breakInfo_number
477 span = modBreaks_locs breaks ! breakInfo_number
478 decl = intercalate "." $ modBreaks_decls breaks ! breakInfo_number
479
480 -- Filter out any unboxed ids;
481 -- we can't bind these at the prompt
482 pointers = filter (\(id,_) -> isPointer id) vars
483 isPointer id | [rep] <- typePrimRep (idType id)
484 , isGcPtrRep rep = True
485 | otherwise = False
486
487 (ids, offsets) = unzip pointers
488
489 free_tvs = tyCoVarsOfTypesList (result_ty:map idType ids)
490
491 -- It might be that getIdValFromApStack fails, because the AP_STACK
492 -- has been accidentally evaluated, or something else has gone wrong.
493 -- So that we don't fall over in a heap when this happens, just don't
494 -- bind any free variables instead, and we emit a warning.
495 mb_hValues <-
496 mapM (getBreakpointVar hsc_env apStack_fhv . fromIntegral) offsets
497 when (any isNothing mb_hValues) $
498 debugTraceMsg (hsc_dflags hsc_env) 1 $
499 text "Warning: _result has been evaluated, some bindings have been lost"
500
501 us <- mkSplitUniqSupply 'I' -- Dodgy; will give the same uniques every time
502 let tv_subst = newTyVars us free_tvs
503 filtered_ids = [ id | (id, Just _hv) <- zip ids mb_hValues ]
504 (_,tidy_tys) = tidyOpenTypes emptyTidyEnv $
505 map (substTy tv_subst . idType) filtered_ids
506
507 new_ids <- zipWith3M mkNewId occs tidy_tys filtered_ids
508 result_name <- newInteractiveBinder hsc_env (mkVarOccFS result_fs) span
509
510 let result_id = Id.mkVanillaGlobal result_name
511 (substTy tv_subst result_ty)
512 result_ok = isPointer result_id
513
514 final_ids | result_ok = result_id : new_ids
515 | otherwise = new_ids
516 ictxt0 = hsc_IC hsc_env
517 ictxt1 = extendInteractiveContextWithIds ictxt0 final_ids
518 names = map idName new_ids
519
520 let fhvs = catMaybes mb_hValues
521 Linker.extendLinkEnv (zip names fhvs)
522 when result_ok $ Linker.extendLinkEnv [(result_name, apStack_fhv)]
523 hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 }
524 return (hsc_env1, if result_ok then result_name:names else names, span, decl)
525 where
526 -- We need a fresh Unique for each Id we bind, because the linker
527 -- state is single-threaded and otherwise we'd spam old bindings
528 -- whenever we stop at a breakpoint. The InteractveContext is properly
529 -- saved/restored, but not the linker state. See #1743, test break026.
530 mkNewId :: OccName -> Type -> Id -> IO Id
531 mkNewId occ ty old_id
532 = do { name <- newInteractiveBinder hsc_env occ (getSrcSpan old_id)
533 ; return (Id.mkVanillaGlobalWithInfo name ty (idInfo old_id)) }
534
535 newTyVars :: UniqSupply -> [TcTyVar] -> TCvSubst
536 -- Similarly, clone the type variables mentioned in the types
537 -- we have here, *and* make them all RuntimeUnk tyvars
538 newTyVars us tvs
539 = mkTvSubstPrs [ (tv, mkTyVarTy (mkRuntimeUnkTyVar name (tyVarKind tv)))
540 | (tv, uniq) <- tvs `zip` uniqsFromSupply us
541 , let name = setNameUnique (tyVarName tv) uniq ]
542
543 rttiEnvironment :: HscEnv -> IO HscEnv
544 rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do
545 let tmp_ids = [id | AnId id <- ic_tythings ic]
546 incompletelyTypedIds =
547 [id | id <- tmp_ids
548 , not $ noSkolems id
549 , (occNameFS.nameOccName.idName) id /= result_fs]
550 hsc_env' <- foldM improveTypes hsc_env (map idName incompletelyTypedIds)
551 return hsc_env'
552 where
553 noSkolems = noFreeVarsOfType . idType
554 improveTypes hsc_env@HscEnv{hsc_IC=ic} name = do
555 let tmp_ids = [id | AnId id <- ic_tythings ic]
556 Just id = find (\i -> idName i == name) tmp_ids
557 if noSkolems id
558 then return hsc_env
559 else do
560 mb_new_ty <- reconstructType hsc_env 10 id
561 let old_ty = idType id
562 case mb_new_ty of
563 Nothing -> return hsc_env
564 Just new_ty -> do
565 case improveRTTIType hsc_env old_ty new_ty of
566 Nothing -> return $
567 WARN(True, text (":print failed to calculate the "
568 ++ "improvement for a type")) hsc_env
569 Just subst -> do
570 let dflags = hsc_dflags hsc_env
571 when (dopt Opt_D_dump_rtti dflags) $
572 printInfoForUser dflags alwaysQualify $
573 fsep [text "RTTI Improvement for", ppr id, equals, ppr subst]
574
575 let ic' = substInteractiveContext ic subst
576 return hsc_env{hsc_IC=ic'}
577
578 pushResume :: HscEnv -> Resume -> HscEnv
579 pushResume hsc_env resume = hsc_env { hsc_IC = ictxt1 }
580 where
581 ictxt0 = hsc_IC hsc_env
582 ictxt1 = ictxt0 { ic_resume = resume : ic_resume ictxt0 }
583
584 -- -----------------------------------------------------------------------------
585 -- Abandoning a resume context
586
587 abandon :: GhcMonad m => m Bool
588 abandon = do
589 hsc_env <- getSession
590 let ic = hsc_IC hsc_env
591 resume = ic_resume ic
592 case resume of
593 [] -> return False
594 r:rs -> do
595 setSession hsc_env{ hsc_IC = ic { ic_resume = rs } }
596 liftIO $ abandonStmt hsc_env (resumeContext r)
597 return True
598
599 abandonAll :: GhcMonad m => m Bool
600 abandonAll = do
601 hsc_env <- getSession
602 let ic = hsc_IC hsc_env
603 resume = ic_resume ic
604 case resume of
605 [] -> return False
606 rs -> do
607 setSession hsc_env{ hsc_IC = ic { ic_resume = [] } }
608 liftIO $ mapM_ (abandonStmt hsc_env. resumeContext) rs
609 return True
610
611 -- -----------------------------------------------------------------------------
612 -- Bounded list, optimised for repeated cons
613
614 data BoundedList a = BL
615 {-# UNPACK #-} !Int -- length
616 {-# UNPACK #-} !Int -- bound
617 [a] -- left
618 [a] -- right, list is (left ++ reverse right)
619
620 nilBL :: Int -> BoundedList a
621 nilBL bound = BL 0 bound [] []
622
623 consBL :: a -> BoundedList a -> BoundedList a
624 consBL a (BL len bound left right)
625 | len < bound = BL (len+1) bound (a:left) right
626 | null right = BL len bound [a] $! tail (reverse left)
627 | otherwise = BL len bound (a:left) $! tail right
628
629 toListBL :: BoundedList a -> [a]
630 toListBL (BL _ _ left right) = left ++ reverse right
631
632 fromListBL :: Int -> [a] -> BoundedList a
633 fromListBL bound l = BL (length l) bound l []
634
635 -- lenBL (BL len _ _ _) = len
636
637 -- -----------------------------------------------------------------------------
638 -- | Set the interactive evaluation context.
639 --
640 -- (setContext imports) sets the ic_imports field (which in turn
641 -- determines what is in scope at the prompt) to 'imports', and
642 -- constructs the ic_rn_glb_env environment to reflect it.
643 --
644 -- We retain in scope all the things defined at the prompt, and kept
645 -- in ic_tythings. (Indeed, they shadow stuff from ic_imports.)
646
647 setContext :: GhcMonad m => [InteractiveImport] -> m ()
648 setContext imports
649 = do { hsc_env <- getSession
650 ; let dflags = hsc_dflags hsc_env
651 ; all_env_err <- liftIO $ findGlobalRdrEnv hsc_env imports
652 ; case all_env_err of
653 Left (mod, err) ->
654 liftIO $ throwGhcExceptionIO (formatError dflags mod err)
655 Right all_env -> do {
656 ; let old_ic = hsc_IC hsc_env
657 !final_rdr_env = all_env `icExtendGblRdrEnv` ic_tythings old_ic
658 ; setSession
659 hsc_env{ hsc_IC = old_ic { ic_imports = imports
660 , ic_rn_gbl_env = final_rdr_env }}}}
661 where
662 formatError dflags mod err = ProgramError . showSDoc dflags $
663 text "Cannot add module" <+> ppr mod <+>
664 text "to context:" <+> text err
665
666 findGlobalRdrEnv :: HscEnv -> [InteractiveImport]
667 -> IO (Either (ModuleName, String) GlobalRdrEnv)
668 -- Compute the GlobalRdrEnv for the interactive context
669 findGlobalRdrEnv hsc_env imports
670 = do { idecls_env <- hscRnImportDecls hsc_env idecls
671 -- This call also loads any orphan modules
672 ; return $ case partitionEithers (map mkEnv imods) of
673 ([], imods_env) -> Right (foldr plusGlobalRdrEnv idecls_env imods_env)
674 (err : _, _) -> Left err }
675 where
676 idecls :: [LImportDecl RdrName]
677 idecls = [noLoc d | IIDecl d <- imports]
678
679 imods :: [ModuleName]
680 imods = [m | IIModule m <- imports]
681
682 mkEnv mod = case mkTopLevEnv (hsc_HPT hsc_env) mod of
683 Left err -> Left (mod, err)
684 Right env -> Right env
685
686 availsToGlobalRdrEnv :: ModuleName -> [AvailInfo] -> GlobalRdrEnv
687 availsToGlobalRdrEnv mod_name avails
688 = mkGlobalRdrEnv (gresFromAvails (Just imp_spec) avails)
689 where
690 -- We're building a GlobalRdrEnv as if the user imported
691 -- all the specified modules into the global interactive module
692 imp_spec = ImpSpec { is_decl = decl, is_item = ImpAll}
693 decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name,
694 is_qual = False,
695 is_dloc = srcLocSpan interactiveSrcLoc }
696
697 mkTopLevEnv :: HomePackageTable -> ModuleName -> Either String GlobalRdrEnv
698 mkTopLevEnv hpt modl
699 = case lookupHpt hpt modl of
700 Nothing -> Left "not a home module"
701 Just details ->
702 case mi_globals (hm_iface details) of
703 Nothing -> Left "not interpreted"
704 Just env -> Right env
705
706 -- | Get the interactive evaluation context, consisting of a pair of the
707 -- set of modules from which we take the full top-level scope, and the set
708 -- of modules from which we take just the exports respectively.
709 getContext :: GhcMonad m => m [InteractiveImport]
710 getContext = withSession $ \HscEnv{ hsc_IC=ic } ->
711 return (ic_imports ic)
712
713 -- | Returns @True@ if the specified module is interpreted, and hence has
714 -- its full top-level scope available.
715 moduleIsInterpreted :: GhcMonad m => Module -> m Bool
716 moduleIsInterpreted modl = withSession $ \h ->
717 if moduleUnitId modl /= thisPackage (hsc_dflags h)
718 then return False
719 else case lookupHpt (hsc_HPT h) (moduleName modl) of
720 Just details -> return (isJust (mi_globals (hm_iface details)))
721 _not_a_home_module -> return False
722
723 -- | Looks up an identifier in the current interactive context (for :info)
724 -- Filter the instances by the ones whose tycons (or clases resp)
725 -- are in scope (qualified or otherwise). Otherwise we list a whole lot too many!
726 -- The exact choice of which ones to show, and which to hide, is a judgement call.
727 -- (see Trac #1581)
728 getInfo :: GhcMonad m => Bool -> Name -> m (Maybe (TyThing,Fixity,[ClsInst],[FamInst]))
729 getInfo allInfo name
730 = withSession $ \hsc_env ->
731 do mb_stuff <- liftIO $ hscTcRnGetInfo hsc_env name
732 case mb_stuff of
733 Nothing -> return Nothing
734 Just (thing, fixity, cls_insts, fam_insts) -> do
735 let rdr_env = ic_rn_gbl_env (hsc_IC hsc_env)
736
737 -- Filter the instances based on whether the constituent names of their
738 -- instance heads are all in scope.
739 let cls_insts' = filter (plausible rdr_env . orphNamesOfClsInst) cls_insts
740 fam_insts' = filter (plausible rdr_env . orphNamesOfFamInst) fam_insts
741 return (Just (thing, fixity, cls_insts', fam_insts'))
742 where
743 plausible rdr_env names
744 -- Dfun involving only names that are in ic_rn_glb_env
745 = allInfo
746 || nameSetAll ok names
747 where -- A name is ok if it's in the rdr_env,
748 -- whether qualified or not
749 ok n | n == name = True
750 -- The one we looked for in the first place!
751 | pretendNameIsInScope n = True
752 | isBuiltInSyntax n = True
753 | isExternalName n = isJust (lookupGRE_Name rdr_env n)
754 | otherwise = True
755
756 -- | Returns all names in scope in the current interactive context
757 getNamesInScope :: GhcMonad m => m [Name]
758 getNamesInScope = withSession $ \hsc_env -> do
759 return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env))))
760
761 -- | Returns all 'RdrName's in scope in the current interactive
762 -- context, excluding any that are internally-generated.
763 getRdrNamesInScope :: GhcMonad m => m [RdrName]
764 getRdrNamesInScope = withSession $ \hsc_env -> do
765 let
766 ic = hsc_IC hsc_env
767 gbl_rdrenv = ic_rn_gbl_env ic
768 gbl_names = concatMap greRdrNames $ globalRdrEnvElts gbl_rdrenv
769 -- Exclude internally generated names; see e.g. Trac #11328
770 return (filter (not . isDerivedOccName . rdrNameOcc) gbl_names)
771
772
773 -- | Parses a string as an identifier, and returns the list of 'Name's that
774 -- the identifier can refer to in the current interactive context.
775 parseName :: GhcMonad m => String -> m [Name]
776 parseName str = withSession $ \hsc_env -> liftIO $
777 do { lrdr_name <- hscParseIdentifier hsc_env str
778 ; hscTcRnLookupRdrName hsc_env lrdr_name }
779
780 -- | Returns @True@ if passed string is a statement.
781 isStmt :: DynFlags -> String -> Bool
782 isStmt dflags stmt =
783 case parseThing Parser.parseStmt dflags stmt of
784 Lexer.POk _ _ -> True
785 Lexer.PFailed _ _ _ -> False
786
787 -- | Returns @True@ if passed string has an import declaration.
788 hasImport :: DynFlags -> String -> Bool
789 hasImport dflags stmt =
790 case parseThing Parser.parseModule dflags stmt of
791 Lexer.POk _ thing -> hasImports thing
792 Lexer.PFailed _ _ _ -> False
793 where
794 hasImports = not . null . hsmodImports . unLoc
795
796 -- | Returns @True@ if passed string is an import declaration.
797 isImport :: DynFlags -> String -> Bool
798 isImport dflags stmt =
799 case parseThing Parser.parseImport dflags stmt of
800 Lexer.POk _ _ -> True
801 Lexer.PFailed _ _ _ -> False
802
803 -- | Returns @True@ if passed string is a declaration but __/not a splice/__.
804 isDecl :: DynFlags -> String -> Bool
805 isDecl dflags stmt = do
806 case parseThing Parser.parseDeclaration dflags stmt of
807 Lexer.POk _ thing ->
808 case unLoc thing of
809 SpliceD _ -> False
810 _ -> True
811 Lexer.PFailed _ _ _ -> False
812
813 parseThing :: Lexer.P thing -> DynFlags -> String -> Lexer.ParseResult thing
814 parseThing parser dflags stmt = do
815 let buf = stringToStringBuffer stmt
816 loc = mkRealSrcLoc (fsLit "<interactive>") 1 1
817
818 Lexer.unP parser (Lexer.mkPState dflags buf loc)
819
820 -- -----------------------------------------------------------------------------
821 -- Getting the type of an expression
822
823 -- | Get the type of an expression
824 -- Returns the type as described by 'TcRnExprMode'
825 exprType :: GhcMonad m => TcRnExprMode -> String -> m Type
826 exprType mode expr = withSession $ \hsc_env -> do
827 ty <- liftIO $ hscTcExpr hsc_env mode expr
828 return $ tidyType emptyTidyEnv ty
829
830 -- -----------------------------------------------------------------------------
831 -- Getting the kind of a type
832
833 -- | Get the kind of a type
834 typeKind :: GhcMonad m => Bool -> String -> m (Type, Kind)
835 typeKind normalise str = withSession $ \hsc_env -> do
836 liftIO $ hscKcType hsc_env normalise str
837
838 -----------------------------------------------------------------------------
839 -- Compile an expression, run it and deliver the result
840
841 -- | Parse an expression, the parsed expression can be further processed and
842 -- passed to compileParsedExpr.
843 parseExpr :: GhcMonad m => String -> m (LHsExpr RdrName)
844 parseExpr expr = withSession $ \hsc_env -> do
845 liftIO $ runInteractiveHsc hsc_env $ hscParseExpr expr
846
847 -- | Compile an expression, run it and deliver the resulting HValue.
848 compileExpr :: GhcMonad m => String -> m HValue
849 compileExpr expr = do
850 parsed_expr <- parseExpr expr
851 compileParsedExpr parsed_expr
852
853 -- | Compile an expression, run it and deliver the resulting HValue.
854 compileExprRemote :: GhcMonad m => String -> m ForeignHValue
855 compileExprRemote expr = do
856 parsed_expr <- parseExpr expr
857 compileParsedExprRemote parsed_expr
858
859 -- | Compile an parsed expression (before renaming), run it and deliver
860 -- the resulting HValue.
861 compileParsedExprRemote :: GhcMonad m => LHsExpr RdrName -> m ForeignHValue
862 compileParsedExprRemote expr@(L loc _) = withSession $ \hsc_env -> do
863 -- > let _compileParsedExpr = expr
864 -- Create let stmt from expr to make hscParsedStmt happy.
865 -- We will ignore the returned [Id], namely [expr_id], and not really
866 -- create a new binding.
867 let expr_fs = fsLit "_compileParsedExpr"
868 expr_name = mkInternalName (getUnique expr_fs) (mkTyVarOccFS expr_fs) loc
869 let_stmt = L loc . LetStmt . L loc . HsValBinds $
870 ValBindsIn (unitBag $ mkHsVarBind loc (getRdrName expr_name) expr) []
871
872 Just ([_id], hvals_io, fix_env) <- liftIO $ hscParsedStmt hsc_env let_stmt
873 updateFixityEnv fix_env
874 status <- liftIO $ evalStmt hsc_env False (EvalThis hvals_io)
875 case status of
876 EvalComplete _ (EvalSuccess [hval]) -> return hval
877 EvalComplete _ (EvalException e) ->
878 liftIO $ throwIO (fromSerializableException e)
879 _ -> panic "compileParsedExpr"
880
881 compileParsedExpr :: GhcMonad m => LHsExpr RdrName -> m HValue
882 compileParsedExpr expr = do
883 fhv <- compileParsedExprRemote expr
884 dflags <- getDynFlags
885 liftIO $ wormhole dflags fhv
886
887 -- | Compile an expression, run it and return the result as a Dynamic.
888 dynCompileExpr :: GhcMonad m => String -> m Dynamic
889 dynCompileExpr expr = do
890 parsed_expr <- parseExpr expr
891 -- > Data.Dynamic.toDyn expr
892 let loc = getLoc parsed_expr
893 to_dyn_expr = mkHsApp (L loc . HsVar . L loc $ getRdrName toDynName)
894 parsed_expr
895 hval <- compileParsedExpr to_dyn_expr
896 return (unsafeCoerce# hval :: Dynamic)
897
898 -----------------------------------------------------------------------------
899 -- show a module and it's source/object filenames
900
901 showModule :: GhcMonad m => ModSummary -> m String
902 showModule mod_summary =
903 withSession $ \hsc_env -> do
904 interpreted <- moduleIsBootOrNotObjectLinkable mod_summary
905 let dflags = hsc_dflags hsc_env
906 return (showModMsg dflags (hscTarget dflags) interpreted mod_summary)
907
908 moduleIsBootOrNotObjectLinkable :: GhcMonad m => ModSummary -> m Bool
909 moduleIsBootOrNotObjectLinkable mod_summary = withSession $ \hsc_env ->
910 case lookupHpt (hsc_HPT hsc_env) (ms_mod_name mod_summary) of
911 Nothing -> panic "missing linkable"
912 Just mod_info -> return $ case hm_linkable mod_info of
913 Nothing -> True
914 Just linkable -> not (isObjectLinkable linkable)
915
916 ----------------------------------------------------------------------------
917 -- RTTI primitives
918
919 obtainTermFromVal :: HscEnv -> Int -> Bool -> Type -> a -> IO Term
920 obtainTermFromVal hsc_env bound force ty x =
921 cvObtainTerm hsc_env bound force ty (unsafeCoerce# x)
922
923 obtainTermFromId :: HscEnv -> Int -> Bool -> Id -> IO Term
924 obtainTermFromId hsc_env bound force id = do
925 let dflags = hsc_dflags hsc_env
926 hv <- Linker.getHValue hsc_env (varName id) >>= wormhole dflags
927 cvObtainTerm hsc_env bound force (idType id) hv
928
929 -- Uses RTTI to reconstruct the type of an Id, making it less polymorphic
930 reconstructType :: HscEnv -> Int -> Id -> IO (Maybe Type)
931 reconstructType hsc_env bound id = do
932 let dflags = hsc_dflags hsc_env
933 hv <- Linker.getHValue hsc_env (varName id) >>= wormhole dflags
934 cvReconstructType hsc_env bound (idType id) hv
935
936 mkRuntimeUnkTyVar :: Name -> Kind -> TyVar
937 mkRuntimeUnkTyVar name kind = mkTcTyVar name kind RuntimeUnk