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