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