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