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