Fix #8487: Debugger confuses variables
[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 parseInstanceHead,
34 getInstancesForType,
35 getDocs,
36 GetDocsFailure(..),
37 showModule,
38 moduleIsBootOrNotObjectLinkable,
39 parseExpr, compileParsedExpr,
40 compileExpr, dynCompileExpr,
41 compileExprRemote, compileParsedExprRemote,
42 Term(..), obtainTermFromId, obtainTermFromVal, reconstructType
43 ) where
44
45 #include "HsVersions.h"
46
47 import GhcPrelude
48
49 import InteractiveEvalTypes
50
51 import GHCi
52 import GHCi.Message
53 import GHCi.RemoteTypes
54 import GhcMonad
55 import HscMain
56 import HsSyn
57 import HscTypes
58 import InstEnv
59 import IfaceEnv ( newInteractiveBinder )
60 import FamInstEnv ( FamInst )
61 import CoreFVs ( orphNamesOfFamInst )
62 import TyCon
63 import Type hiding( typeKind )
64 import RepType
65 import TcType
66 import Var
67 import Id
68 import Name hiding ( varName )
69 import NameSet
70 import Avail
71 import RdrName
72 import VarEnv
73 import ByteCodeTypes
74 import Linker
75 import DynFlags
76 import Unique
77 import UniqSupply
78 import MonadUtils
79 import Module
80 import PrelNames ( toDynName, pretendNameIsInScope )
81 import TysWiredIn ( isCTupleTyConName )
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 Util
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 Data.Map (Map)
100 import qualified Data.Map as Map
101 import StringBuffer (stringToStringBuffer)
102 import Control.Monad
103 import GHC.Exts
104 import Data.Array
105 import Exception
106
107 import TcRnDriver ( runTcInteractive, tcRnType )
108 import TcHsSyn ( ZonkFlexi (SkolemiseFlexi) )
109
110 import TcEnv (tcGetInstEnvs)
111
112 import Inst (instDFunType)
113 import TcSimplify (solveWanteds)
114 import TcRnMonad
115 import TcEvidence
116 import Data.Bifunctor (second)
117
118 import TcSMonad (runTcS)
119
120 -- -----------------------------------------------------------------------------
121 -- running a statement interactively
122
123 getResumeContext :: GhcMonad m => m [Resume]
124 getResumeContext = withSession (return . ic_resume . hsc_IC)
125
126 mkHistory :: HscEnv -> ForeignHValue -> BreakInfo -> History
127 mkHistory hsc_env hval bi = History hval bi (findEnclosingDecls hsc_env bi)
128
129 getHistoryModule :: History -> Module
130 getHistoryModule = breakInfo_module . historyBreakInfo
131
132 getHistorySpan :: HscEnv -> History -> SrcSpan
133 getHistorySpan hsc_env History{..} =
134 let BreakInfo{..} = historyBreakInfo in
135 case lookupHpt (hsc_HPT hsc_env) (moduleName breakInfo_module) of
136 Just hmi -> modBreaks_locs (getModBreaks hmi) ! breakInfo_number
137 _ -> panic "getHistorySpan"
138
139 getModBreaks :: HomeModInfo -> ModBreaks
140 getModBreaks hmi
141 | Just linkable <- hm_linkable hmi,
142 [BCOs cbc _] <- linkableUnlinked linkable
143 = fromMaybe emptyModBreaks (bc_breaks cbc)
144 | otherwise
145 = emptyModBreaks -- probably object code
146
147 {- | Finds the enclosing top level function name -}
148 -- ToDo: a better way to do this would be to keep hold of the decl_path computed
149 -- by the coverage pass, which gives the list of lexically-enclosing bindings
150 -- for each tick.
151 findEnclosingDecls :: HscEnv -> BreakInfo -> [String]
152 findEnclosingDecls hsc_env (BreakInfo modl ix) =
153 let hmi = expectJust "findEnclosingDecls" $
154 lookupHpt (hsc_HPT hsc_env) (moduleName modl)
155 mb = getModBreaks hmi
156 in modBreaks_decls mb ! ix
157
158 -- | Update fixity environment in the current interactive context.
159 updateFixityEnv :: GhcMonad m => FixityEnv -> m ()
160 updateFixityEnv fix_env = do
161 hsc_env <- getSession
162 let ic = hsc_IC hsc_env
163 setSession $ hsc_env { hsc_IC = ic { ic_fix_env = fix_env } }
164
165 -- -----------------------------------------------------------------------------
166 -- execStmt
167
168 -- | default ExecOptions
169 execOptions :: ExecOptions
170 execOptions = ExecOptions
171 { execSingleStep = RunToCompletion
172 , execSourceFile = "<interactive>"
173 , execLineNumber = 1
174 , execWrap = EvalThis -- just run the statement, don't wrap it in anything
175 }
176
177 -- | Run a statement in the current interactive context.
178 execStmt
179 :: GhcMonad m
180 => String -- ^ a statement (bind or expression)
181 -> ExecOptions
182 -> m ExecResult
183 execStmt input exec_opts@ExecOptions{..} = do
184 hsc_env <- getSession
185
186 mb_stmt <-
187 liftIO $
188 runInteractiveHsc hsc_env $
189 hscParseStmtWithLocation execSourceFile execLineNumber input
190
191 case mb_stmt of
192 -- empty statement / comment
193 Nothing -> return (ExecComplete (Right []) 0)
194 Just stmt -> execStmt' stmt input exec_opts
195
196 -- | Like `execStmt`, but takes a parsed statement as argument. Useful when
197 -- doing preprocessing on the AST before execution, e.g. in GHCi (see
198 -- GHCi.UI.runStmt).
199 execStmt' :: GhcMonad m => GhciLStmt GhcPs -> String -> ExecOptions -> m ExecResult
200 execStmt' stmt stmt_text ExecOptions{..} = do
201 hsc_env <- getSession
202
203 -- Turn off -fwarn-unused-local-binds when running a statement, to hide
204 -- warnings about the implicit bindings we introduce.
205 -- (This is basically `mkInteractiveHscEnv hsc_env`, except we unset
206 -- -wwarn-unused-local-binds)
207 let ic = hsc_IC hsc_env -- use the interactive dflags
208 idflags' = ic_dflags ic `wopt_unset` Opt_WarnUnusedLocalBinds
209 hsc_env' = mkInteractiveHscEnv (hsc_env{ hsc_IC = ic{ ic_dflags = idflags' } })
210
211 r <- liftIO $ hscParsedStmt hsc_env' stmt
212
213 case r of
214 Nothing ->
215 -- empty statement / comment
216 return (ExecComplete (Right []) 0)
217 Just (ids, hval, fix_env) -> do
218 updateFixityEnv fix_env
219
220 status <-
221 withVirtualCWD $
222 liftIO $
223 evalStmt hsc_env' (isStep execSingleStep) (execWrap hval)
224
225 let ic = hsc_IC hsc_env
226 bindings = (ic_tythings ic, ic_rn_gbl_env ic)
227
228 size = ghciHistSize idflags'
229
230 handleRunStatus execSingleStep stmt_text bindings ids
231 status (emptyHistory size)
232
233 runDecls :: GhcMonad m => String -> m [Name]
234 runDecls = runDeclsWithLocation "<interactive>" 1
235
236 -- | Run some declarations and return any user-visible names that were brought
237 -- into scope.
238 runDeclsWithLocation :: GhcMonad m => String -> Int -> String -> m [Name]
239 runDeclsWithLocation source line_num input = do
240 hsc_env <- getSession
241 decls <- liftIO (hscParseDeclsWithLocation hsc_env source line_num input)
242 runParsedDecls decls
243
244 -- | Like `runDeclsWithLocation`, but takes parsed declarations as argument.
245 -- Useful when doing preprocessing on the AST before execution, e.g. in GHCi
246 -- (see GHCi.UI.runStmt).
247 runParsedDecls :: GhcMonad m => [LHsDecl GhcPs] -> m [Name]
248 runParsedDecls decls = do
249 hsc_env <- getSession
250 (tyThings, ic) <- liftIO (hscParsedDecls hsc_env decls)
251
252 setSession $ hsc_env { hsc_IC = ic }
253 hsc_env <- getSession
254 hsc_env' <- liftIO $ rttiEnvironment hsc_env
255 setSession hsc_env'
256 return $ filter (not . isDerivedOccName . nameOccName)
257 -- For this filter, see Note [What to show to users]
258 $ map getName tyThings
259
260 {- Note [What to show to users]
261 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
262 We don't want to display internally-generated bindings to users.
263 Things like the coercion axiom for newtypes. These bindings all get
264 OccNames that users can't write, to avoid the possibility of name
265 clashes (in linker symbols). That gives a convenient way to suppress
266 them. The relevant predicate is OccName.isDerivedOccName.
267 See #11051 for more background and examples.
268 -}
269
270 withVirtualCWD :: GhcMonad m => m a -> m a
271 withVirtualCWD m = do
272 hsc_env <- getSession
273
274 -- a virtual CWD is only necessary when we're running interpreted code in
275 -- the same process as the compiler.
276 if gopt Opt_ExternalInterpreter (hsc_dflags hsc_env) then m else do
277
278 let ic = hsc_IC hsc_env
279 let set_cwd = do
280 dir <- liftIO $ getCurrentDirectory
281 case ic_cwd ic of
282 Just dir -> liftIO $ setCurrentDirectory dir
283 Nothing -> return ()
284 return dir
285
286 reset_cwd orig_dir = do
287 virt_dir <- liftIO $ getCurrentDirectory
288 hsc_env <- getSession
289 let old_IC = hsc_IC hsc_env
290 setSession hsc_env{ hsc_IC = old_IC{ ic_cwd = Just virt_dir } }
291 liftIO $ setCurrentDirectory orig_dir
292
293 gbracket set_cwd reset_cwd $ \_ -> m
294
295 parseImportDecl :: GhcMonad m => String -> m (ImportDecl GhcPs)
296 parseImportDecl expr = withSession $ \hsc_env -> liftIO $ hscImport hsc_env expr
297
298 emptyHistory :: Int -> BoundedList History
299 emptyHistory size = nilBL size
300
301 handleRunStatus :: GhcMonad m
302 => SingleStep -> String-> ([TyThing],GlobalRdrEnv) -> [Id]
303 -> EvalStatus_ [ForeignHValue] [HValueRef]
304 -> BoundedList History
305 -> m ExecResult
306
307 handleRunStatus step expr bindings final_ids status history
308 | RunAndLogSteps <- step = tracing
309 | otherwise = not_tracing
310 where
311 tracing
312 | EvalBreak is_exception apStack_ref ix mod_uniq resume_ctxt _ccs <- status
313 , not is_exception
314 = do
315 hsc_env <- getSession
316 let hmi = expectJust "handleRunStatus" $
317 lookupHptDirectly (hsc_HPT hsc_env)
318 (mkUniqueGrimily mod_uniq)
319 modl = mi_module (hm_iface hmi)
320 breaks = getModBreaks hmi
321
322 b <- liftIO $
323 breakpointStatus hsc_env (modBreaks_flags breaks) ix
324 if b
325 then not_tracing
326 -- This breakpoint is explicitly enabled; we want to stop
327 -- instead of just logging it.
328 else do
329 apStack_fhv <- liftIO $ mkFinalizedHValue hsc_env apStack_ref
330 let bi = BreakInfo modl ix
331 !history' = mkHistory hsc_env apStack_fhv bi `consBL` history
332 -- history is strict, otherwise our BoundedList is pointless.
333 fhv <- liftIO $ mkFinalizedHValue hsc_env resume_ctxt
334 status <- liftIO $ GHCi.resumeStmt hsc_env True fhv
335 handleRunStatus RunAndLogSteps expr bindings final_ids
336 status history'
337 | otherwise
338 = not_tracing
339
340 not_tracing
341 -- Hit a breakpoint
342 | EvalBreak is_exception apStack_ref ix mod_uniq resume_ctxt ccs <- status
343 = do
344 hsc_env <- getSession
345 resume_ctxt_fhv <- liftIO $ mkFinalizedHValue hsc_env resume_ctxt
346 apStack_fhv <- liftIO $ mkFinalizedHValue hsc_env apStack_ref
347 let hmi = expectJust "handleRunStatus" $
348 lookupHptDirectly (hsc_HPT hsc_env)
349 (mkUniqueGrimily mod_uniq)
350 modl = mi_module (hm_iface hmi)
351 bp | is_exception = Nothing
352 | otherwise = Just (BreakInfo modl ix)
353 (hsc_env1, names, span, decl) <- liftIO $
354 bindLocalsAtBreakpoint hsc_env apStack_fhv bp
355 let
356 resume = Resume
357 { resumeStmt = expr, resumeContext = resume_ctxt_fhv
358 , resumeBindings = bindings, resumeFinalIds = final_ids
359 , resumeApStack = apStack_fhv
360 , resumeBreakInfo = bp
361 , resumeSpan = span, resumeHistory = toListBL history
362 , resumeDecl = decl
363 , resumeCCS = ccs
364 , resumeHistoryIx = 0 }
365 hsc_env2 = pushResume hsc_env1 resume
366
367 setSession hsc_env2
368 return (ExecBreak names bp)
369
370 -- Completed successfully
371 | EvalComplete allocs (EvalSuccess hvals) <- status
372 = do hsc_env <- getSession
373 let final_ic = extendInteractiveContextWithIds (hsc_IC hsc_env) final_ids
374 final_names = map getName final_ids
375 dl = hsc_dynLinker hsc_env
376 liftIO $ Linker.extendLinkEnv dl (zip final_names hvals)
377 hsc_env' <- liftIO $ rttiEnvironment hsc_env{hsc_IC=final_ic}
378 setSession hsc_env'
379 return (ExecComplete (Right final_names) allocs)
380
381 -- Completed with an exception
382 | EvalComplete alloc (EvalException e) <- status
383 = return (ExecComplete (Left (fromSerializableException e)) alloc)
384
385 | otherwise
386 = panic "not_tracing" -- actually exhaustive, but GHC can't tell
387
388
389 resumeExec :: GhcMonad m => (SrcSpan->Bool) -> SingleStep -> m ExecResult
390 resumeExec canLogSpan step
391 = do
392 hsc_env <- getSession
393 let ic = hsc_IC hsc_env
394 resume = ic_resume ic
395
396 case resume of
397 [] -> liftIO $
398 throwGhcExceptionIO (ProgramError "not stopped at a breakpoint")
399 (r:rs) -> do
400 -- unbind the temporary locals by restoring the TypeEnv from
401 -- before the breakpoint, and drop this Resume from the
402 -- InteractiveContext.
403 let (resume_tmp_te,resume_rdr_env) = resumeBindings r
404 ic' = ic { ic_tythings = resume_tmp_te,
405 ic_rn_gbl_env = resume_rdr_env,
406 ic_resume = rs }
407 setSession hsc_env{ hsc_IC = ic' }
408
409 -- remove any bindings created since the breakpoint from the
410 -- linker's environment
411 let old_names = map getName resume_tmp_te
412 new_names = [ n | thing <- ic_tythings ic
413 , let n = getName thing
414 , not (n `elem` old_names) ]
415 dl = hsc_dynLinker hsc_env
416 liftIO $ Linker.deleteFromLinkEnv dl new_names
417
418 case r of
419 Resume { resumeStmt = expr, resumeContext = fhv
420 , resumeBindings = bindings, resumeFinalIds = final_ids
421 , resumeApStack = apStack, resumeBreakInfo = mb_brkpt
422 , resumeSpan = span
423 , resumeHistory = hist } -> do
424 withVirtualCWD $ do
425 status <- liftIO $ GHCi.resumeStmt hsc_env (isStep step) fhv
426 let prevHistoryLst = fromListBL 50 hist
427 hist' = case mb_brkpt of
428 Nothing -> prevHistoryLst
429 Just bi
430 | not $canLogSpan span -> prevHistoryLst
431 | otherwise -> mkHistory hsc_env apStack bi `consBL`
432 fromListBL 50 hist
433 handleRunStatus step expr bindings final_ids status hist'
434
435 back :: GhcMonad m => Int -> m ([Name], Int, SrcSpan, String)
436 back n = moveHist (+n)
437
438 forward :: GhcMonad m => Int -> m ([Name], Int, SrcSpan, String)
439 forward n = moveHist (subtract n)
440
441 moveHist :: GhcMonad m => (Int -> Int) -> m ([Name], Int, SrcSpan, String)
442 moveHist fn = do
443 hsc_env <- getSession
444 case ic_resume (hsc_IC hsc_env) of
445 [] -> liftIO $
446 throwGhcExceptionIO (ProgramError "not stopped at a breakpoint")
447 (r:rs) -> do
448 let ix = resumeHistoryIx r
449 history = resumeHistory r
450 new_ix = fn ix
451 --
452 when (history `lengthLessThan` new_ix) $ liftIO $
453 throwGhcExceptionIO (ProgramError "no more logged breakpoints")
454 when (new_ix < 0) $ liftIO $
455 throwGhcExceptionIO (ProgramError "already at the beginning of the history")
456
457 let
458 update_ic apStack mb_info = do
459 (hsc_env1, names, span, decl) <-
460 liftIO $ bindLocalsAtBreakpoint hsc_env apStack mb_info
461 let ic = hsc_IC hsc_env1
462 r' = r { resumeHistoryIx = new_ix }
463 ic' = ic { ic_resume = r':rs }
464
465 setSession hsc_env1{ hsc_IC = ic' }
466
467 return (names, new_ix, span, decl)
468
469 -- careful: we want apStack to be the AP_STACK itself, not a thunk
470 -- around it, hence the cases are carefully constructed below to
471 -- make this the case. ToDo: this is v. fragile, do something better.
472 if new_ix == 0
473 then case r of
474 Resume { resumeApStack = apStack,
475 resumeBreakInfo = mb_brkpt } ->
476 update_ic apStack mb_brkpt
477 else case history !! (new_ix - 1) of
478 History{..} ->
479 update_ic historyApStack (Just historyBreakInfo)
480
481
482 -- -----------------------------------------------------------------------------
483 -- After stopping at a breakpoint, add free variables to the environment
484
485 result_fs :: FastString
486 result_fs = fsLit "_result"
487
488 bindLocalsAtBreakpoint
489 :: HscEnv
490 -> ForeignHValue
491 -> Maybe BreakInfo
492 -> IO (HscEnv, [Name], SrcSpan, String)
493
494 -- Nothing case: we stopped when an exception was raised, not at a
495 -- breakpoint. We have no location information or local variables to
496 -- bind, all we can do is bind a local variable to the exception
497 -- value.
498 bindLocalsAtBreakpoint hsc_env apStack Nothing = do
499 let exn_occ = mkVarOccFS (fsLit "_exception")
500 span = mkGeneralSrcSpan (fsLit "<unknown>")
501 exn_name <- newInteractiveBinder hsc_env exn_occ span
502
503 let e_fs = fsLit "e"
504 e_name = mkInternalName (getUnique e_fs) (mkTyVarOccFS e_fs) span
505 e_tyvar = mkRuntimeUnkTyVar e_name liftedTypeKind
506 exn_id = Id.mkVanillaGlobal exn_name (mkTyVarTy e_tyvar)
507
508 ictxt0 = hsc_IC hsc_env
509 ictxt1 = extendInteractiveContextWithIds ictxt0 [exn_id]
510 dl = hsc_dynLinker hsc_env
511 --
512 Linker.extendLinkEnv dl [(exn_name, apStack)]
513 return (hsc_env{ hsc_IC = ictxt1 }, [exn_name], span, "<exception thrown>")
514
515 -- Just case: we stopped at a breakpoint, we have information about the location
516 -- of the breakpoint and the free variables of the expression.
517 bindLocalsAtBreakpoint hsc_env apStack_fhv (Just BreakInfo{..}) = do
518 let
519 hmi = expectJust "bindLocalsAtBreakpoint" $
520 lookupHpt (hsc_HPT hsc_env) (moduleName breakInfo_module)
521 breaks = getModBreaks hmi
522 info = expectJust "bindLocalsAtBreakpoint2" $
523 IntMap.lookup breakInfo_number (modBreaks_breakInfo breaks)
524 mbVars = cgb_vars info
525 result_ty = cgb_resty info
526 occs = modBreaks_vars breaks ! breakInfo_number
527 span = modBreaks_locs breaks ! breakInfo_number
528 decl = intercalate "." $ modBreaks_decls breaks ! breakInfo_number
529
530 -- Filter out any unboxed ids by changing them to Nothings;
531 -- we can't bind these at the prompt
532 mbPointers = nullUnboxed <$> mbVars
533
534 (ids, offsets, occs') = syncOccs mbPointers occs
535
536 free_tvs = tyCoVarsOfTypesList (result_ty:map idType ids)
537
538 -- It might be that getIdValFromApStack fails, because the AP_STACK
539 -- has been accidentally evaluated, or something else has gone wrong.
540 -- So that we don't fall over in a heap when this happens, just don't
541 -- bind any free variables instead, and we emit a warning.
542 mb_hValues <-
543 mapM (getBreakpointVar hsc_env apStack_fhv . fromIntegral) offsets
544 when (any isNothing mb_hValues) $
545 debugTraceMsg (hsc_dflags hsc_env) 1 $
546 text "Warning: _result has been evaluated, some bindings have been lost"
547
548 us <- mkSplitUniqSupply 'I' -- Dodgy; will give the same uniques every time
549 let tv_subst = newTyVars us free_tvs
550 (filtered_ids, occs'') = unzip -- again, sync the occ-names
551 [ (id, occ) | (id, Just _hv, occ) <- zip3 ids mb_hValues occs' ]
552 (_,tidy_tys) = tidyOpenTypes emptyTidyEnv $
553 map (substTy tv_subst . idType) filtered_ids
554
555 new_ids <- zipWith3M mkNewId occs'' tidy_tys filtered_ids
556 result_name <- newInteractiveBinder hsc_env (mkVarOccFS result_fs) span
557
558 let result_id = Id.mkVanillaGlobal result_name
559 (substTy tv_subst result_ty)
560 result_ok = isPointer result_id
561
562 final_ids | result_ok = result_id : new_ids
563 | otherwise = new_ids
564 ictxt0 = hsc_IC hsc_env
565 ictxt1 = extendInteractiveContextWithIds ictxt0 final_ids
566 names = map idName new_ids
567 dl = hsc_dynLinker hsc_env
568
569 let fhvs = catMaybes mb_hValues
570 Linker.extendLinkEnv dl (zip names fhvs)
571 when result_ok $ Linker.extendLinkEnv dl [(result_name, apStack_fhv)]
572 hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 }
573 return (hsc_env1, if result_ok then result_name:names else names, span, decl)
574 where
575 -- We need a fresh Unique for each Id we bind, because the linker
576 -- state is single-threaded and otherwise we'd spam old bindings
577 -- whenever we stop at a breakpoint. The InteractveContext is properly
578 -- saved/restored, but not the linker state. See #1743, test break026.
579 mkNewId :: OccName -> Type -> Id -> IO Id
580 mkNewId occ ty old_id
581 = do { name <- newInteractiveBinder hsc_env occ (getSrcSpan old_id)
582 ; return (Id.mkVanillaGlobalWithInfo name ty (idInfo old_id)) }
583
584 newTyVars :: UniqSupply -> [TcTyVar] -> TCvSubst
585 -- Similarly, clone the type variables mentioned in the types
586 -- we have here, *and* make them all RuntimeUnk tyvars
587 newTyVars us tvs
588 = mkTvSubstPrs [ (tv, mkTyVarTy (mkRuntimeUnkTyVar name (tyVarKind tv)))
589 | (tv, uniq) <- tvs `zip` uniqsFromSupply us
590 , let name = setNameUnique (tyVarName tv) uniq ]
591
592 isPointer id | [rep] <- typePrimRep (idType id)
593 , isGcPtrRep rep = True
594 | otherwise = False
595
596 -- Convert unboxed Id's to Nothings
597 nullUnboxed (Just (fv@(id, _)))
598 | isPointer id = Just fv
599 | otherwise = Nothing
600 nullUnboxed Nothing = Nothing
601
602 -- See Note [Syncing breakpoint info]
603 syncOccs :: [Maybe (a,b)] -> [c] -> ([a], [b], [c])
604 syncOccs mbVs ocs = unzip3 $ catMaybes $ joinOccs mbVs ocs
605 where
606 joinOccs :: [Maybe (a,b)] -> [c] -> [Maybe (a,b,c)]
607 joinOccs = zipWith joinOcc
608 joinOcc mbV oc = (\(a,b) c -> (a,b,c)) <$> mbV <*> pure oc
609
610 rttiEnvironment :: HscEnv -> IO HscEnv
611 rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do
612 let tmp_ids = [id | AnId id <- ic_tythings ic]
613 incompletelyTypedIds =
614 [id | id <- tmp_ids
615 , not $ noSkolems id
616 , (occNameFS.nameOccName.idName) id /= result_fs]
617 hsc_env' <- foldM improveTypes hsc_env (map idName incompletelyTypedIds)
618 return hsc_env'
619 where
620 noSkolems = noFreeVarsOfType . idType
621 improveTypes hsc_env@HscEnv{hsc_IC=ic} name = do
622 let tmp_ids = [id | AnId id <- ic_tythings ic]
623 Just id = find (\i -> idName i == name) tmp_ids
624 if noSkolems id
625 then return hsc_env
626 else do
627 mb_new_ty <- reconstructType hsc_env 10 id
628 let old_ty = idType id
629 case mb_new_ty of
630 Nothing -> return hsc_env
631 Just new_ty -> do
632 case improveRTTIType hsc_env old_ty new_ty of
633 Nothing -> return $
634 WARN(True, text (":print failed to calculate the "
635 ++ "improvement for a type")) hsc_env
636 Just subst -> do
637 let dflags = hsc_dflags hsc_env
638 dumpIfSet_dyn dflags Opt_D_dump_rtti "RTTI"
639 (fsep [text "RTTI Improvement for", ppr id, equals,
640 ppr subst])
641
642 let ic' = substInteractiveContext ic subst
643 return hsc_env{hsc_IC=ic'}
644
645 pushResume :: HscEnv -> Resume -> HscEnv
646 pushResume hsc_env resume = hsc_env { hsc_IC = ictxt1 }
647 where
648 ictxt0 = hsc_IC hsc_env
649 ictxt1 = ictxt0 { ic_resume = resume : ic_resume ictxt0 }
650
651
652 {-
653 Note [Syncing breakpoint info]
654
655 To display the values of the free variables for a single breakpoint, the
656 function `compiler/main/InteractiveEval.hs:bindLocalsAtBreakpoint` pulls
657 out the information from the fields `modBreaks_breakInfo` and
658 `modBreaks_vars` of the `ModBreaks` data structure.
659 For a specific breakpoint this gives 2 lists of type `Id` (or `Var`)
660 and `OccName`.
661 They are used to create the Id's for the free variables and must be kept
662 in sync!
663
664 There are 3 situations where items are removed from the Id list
665 (or replaced with `Nothing`):
666 1.) If function `compiler/ghci/ByteCodeGen.hs:schemeER_wrk` (which creates
667 the Id list) doesn't find an Id in the ByteCode environement.
668 2.) If function `compiler/main/InteractiveEval.hs:bindLocalsAtBreakpoint`
669 filters out unboxed elements from the Id list, because GHCi cannot
670 yet handle them.
671 3.) If the GHCi interpreter doesn't find the reference to a free variable
672 of our breakpoint. This also happens in the function
673 bindLocalsAtBreakpoint.
674
675 If an element is removed from the Id list, then the corresponding element
676 must also be removed from the Occ list. Otherwise GHCi will confuse
677 variable names as in #8487.
678 -}
679
680 -- -----------------------------------------------------------------------------
681 -- Abandoning a resume context
682
683 abandon :: GhcMonad m => m Bool
684 abandon = do
685 hsc_env <- getSession
686 let ic = hsc_IC hsc_env
687 resume = ic_resume ic
688 case resume of
689 [] -> return False
690 r:rs -> do
691 setSession hsc_env{ hsc_IC = ic { ic_resume = rs } }
692 liftIO $ abandonStmt hsc_env (resumeContext r)
693 return True
694
695 abandonAll :: GhcMonad m => m Bool
696 abandonAll = do
697 hsc_env <- getSession
698 let ic = hsc_IC hsc_env
699 resume = ic_resume ic
700 case resume of
701 [] -> return False
702 rs -> do
703 setSession hsc_env{ hsc_IC = ic { ic_resume = [] } }
704 liftIO $ mapM_ (abandonStmt hsc_env. resumeContext) rs
705 return True
706
707 -- -----------------------------------------------------------------------------
708 -- Bounded list, optimised for repeated cons
709
710 data BoundedList a = BL
711 {-# UNPACK #-} !Int -- length
712 {-# UNPACK #-} !Int -- bound
713 [a] -- left
714 [a] -- right, list is (left ++ reverse right)
715
716 nilBL :: Int -> BoundedList a
717 nilBL bound = BL 0 bound [] []
718
719 consBL :: a -> BoundedList a -> BoundedList a
720 consBL a (BL len bound left right)
721 | len < bound = BL (len+1) bound (a:left) right
722 | null right = BL len bound [a] $! tail (reverse left)
723 | otherwise = BL len bound (a:left) $! tail right
724
725 toListBL :: BoundedList a -> [a]
726 toListBL (BL _ _ left right) = left ++ reverse right
727
728 fromListBL :: Int -> [a] -> BoundedList a
729 fromListBL bound l = BL (length l) bound l []
730
731 -- lenBL (BL len _ _ _) = len
732
733 -- -----------------------------------------------------------------------------
734 -- | Set the interactive evaluation context.
735 --
736 -- (setContext imports) sets the ic_imports field (which in turn
737 -- determines what is in scope at the prompt) to 'imports', and
738 -- constructs the ic_rn_glb_env environment to reflect it.
739 --
740 -- We retain in scope all the things defined at the prompt, and kept
741 -- in ic_tythings. (Indeed, they shadow stuff from ic_imports.)
742
743 setContext :: GhcMonad m => [InteractiveImport] -> m ()
744 setContext imports
745 = do { hsc_env <- getSession
746 ; let dflags = hsc_dflags hsc_env
747 ; all_env_err <- liftIO $ findGlobalRdrEnv hsc_env imports
748 ; case all_env_err of
749 Left (mod, err) ->
750 liftIO $ throwGhcExceptionIO (formatError dflags mod err)
751 Right all_env -> do {
752 ; let old_ic = hsc_IC hsc_env
753 !final_rdr_env = all_env `icExtendGblRdrEnv` ic_tythings old_ic
754 ; setSession
755 hsc_env{ hsc_IC = old_ic { ic_imports = imports
756 , ic_rn_gbl_env = final_rdr_env }}}}
757 where
758 formatError dflags mod err = ProgramError . showSDoc dflags $
759 text "Cannot add module" <+> ppr mod <+>
760 text "to context:" <+> text err
761
762 findGlobalRdrEnv :: HscEnv -> [InteractiveImport]
763 -> IO (Either (ModuleName, String) GlobalRdrEnv)
764 -- Compute the GlobalRdrEnv for the interactive context
765 findGlobalRdrEnv hsc_env imports
766 = do { idecls_env <- hscRnImportDecls hsc_env idecls
767 -- This call also loads any orphan modules
768 ; return $ case partitionEithers (map mkEnv imods) of
769 ([], imods_env) -> Right (foldr plusGlobalRdrEnv idecls_env imods_env)
770 (err : _, _) -> Left err }
771 where
772 idecls :: [LImportDecl GhcPs]
773 idecls = [noLoc d | IIDecl d <- imports]
774
775 imods :: [ModuleName]
776 imods = [m | IIModule m <- imports]
777
778 mkEnv mod = case mkTopLevEnv (hsc_HPT hsc_env) mod of
779 Left err -> Left (mod, err)
780 Right env -> Right env
781
782 availsToGlobalRdrEnv :: ModuleName -> [AvailInfo] -> GlobalRdrEnv
783 availsToGlobalRdrEnv mod_name avails
784 = mkGlobalRdrEnv (gresFromAvails (Just imp_spec) avails)
785 where
786 -- We're building a GlobalRdrEnv as if the user imported
787 -- all the specified modules into the global interactive module
788 imp_spec = ImpSpec { is_decl = decl, is_item = ImpAll}
789 decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name,
790 is_qual = False,
791 is_dloc = srcLocSpan interactiveSrcLoc }
792
793 mkTopLevEnv :: HomePackageTable -> ModuleName -> Either String GlobalRdrEnv
794 mkTopLevEnv hpt modl
795 = case lookupHpt hpt modl of
796 Nothing -> Left "not a home module"
797 Just details ->
798 case mi_globals (hm_iface details) of
799 Nothing -> Left "not interpreted"
800 Just env -> Right env
801
802 -- | Get the interactive evaluation context, consisting of a pair of the
803 -- set of modules from which we take the full top-level scope, and the set
804 -- of modules from which we take just the exports respectively.
805 getContext :: GhcMonad m => m [InteractiveImport]
806 getContext = withSession $ \HscEnv{ hsc_IC=ic } ->
807 return (ic_imports ic)
808
809 -- | Returns @True@ if the specified module is interpreted, and hence has
810 -- its full top-level scope available.
811 moduleIsInterpreted :: GhcMonad m => Module -> m Bool
812 moduleIsInterpreted modl = withSession $ \h ->
813 if moduleUnitId modl /= thisPackage (hsc_dflags h)
814 then return False
815 else case lookupHpt (hsc_HPT h) (moduleName modl) of
816 Just details -> return (isJust (mi_globals (hm_iface details)))
817 _not_a_home_module -> return False
818
819 -- | Looks up an identifier in the current interactive context (for :info)
820 -- Filter the instances by the ones whose tycons (or clases resp)
821 -- are in scope (qualified or otherwise). Otherwise we list a whole lot too many!
822 -- The exact choice of which ones to show, and which to hide, is a judgement call.
823 -- (see #1581)
824 getInfo :: GhcMonad m => Bool -> Name
825 -> m (Maybe (TyThing,Fixity,[ClsInst],[FamInst], SDoc))
826 getInfo allInfo name
827 = withSession $ \hsc_env ->
828 do mb_stuff <- liftIO $ hscTcRnGetInfo hsc_env name
829 case mb_stuff of
830 Nothing -> return Nothing
831 Just (thing, fixity, cls_insts, fam_insts, docs) -> do
832 let rdr_env = ic_rn_gbl_env (hsc_IC hsc_env)
833
834 -- Filter the instances based on whether the constituent names of their
835 -- instance heads are all in scope.
836 let cls_insts' = filter (plausible rdr_env . orphNamesOfClsInst) cls_insts
837 fam_insts' = filter (plausible rdr_env . orphNamesOfFamInst) fam_insts
838 return (Just (thing, fixity, cls_insts', fam_insts', docs))
839 where
840 plausible rdr_env names
841 -- Dfun involving only names that are in ic_rn_glb_env
842 = allInfo
843 || nameSetAll ok names
844 where -- A name is ok if it's in the rdr_env,
845 -- whether qualified or not
846 ok n | n == name = True
847 -- The one we looked for in the first place!
848 | pretendNameIsInScope n = True
849 | isBuiltInSyntax n = True
850 | isCTupleTyConName n = True
851 | isExternalName n = isJust (lookupGRE_Name rdr_env n)
852 | otherwise = True
853
854 -- | Returns all names in scope in the current interactive context
855 getNamesInScope :: GhcMonad m => m [Name]
856 getNamesInScope = withSession $ \hsc_env -> do
857 return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env))))
858
859 -- | Returns all 'RdrName's in scope in the current interactive
860 -- context, excluding any that are internally-generated.
861 getRdrNamesInScope :: GhcMonad m => m [RdrName]
862 getRdrNamesInScope = withSession $ \hsc_env -> do
863 let
864 ic = hsc_IC hsc_env
865 gbl_rdrenv = ic_rn_gbl_env ic
866 gbl_names = concatMap greRdrNames $ globalRdrEnvElts gbl_rdrenv
867 -- Exclude internally generated names; see e.g. #11328
868 return (filter (not . isDerivedOccName . rdrNameOcc) gbl_names)
869
870
871 -- | Parses a string as an identifier, and returns the list of 'Name's that
872 -- the identifier can refer to in the current interactive context.
873 parseName :: GhcMonad m => String -> m [Name]
874 parseName str = withSession $ \hsc_env -> liftIO $
875 do { lrdr_name <- hscParseIdentifier hsc_env str
876 ; hscTcRnLookupRdrName hsc_env lrdr_name }
877
878 -- | Returns @True@ if passed string is a statement.
879 isStmt :: DynFlags -> String -> Bool
880 isStmt dflags stmt =
881 case parseThing Parser.parseStmt dflags stmt of
882 Lexer.POk _ _ -> True
883 Lexer.PFailed _ -> False
884
885 -- | Returns @True@ if passed string has an import declaration.
886 hasImport :: DynFlags -> String -> Bool
887 hasImport dflags stmt =
888 case parseThing Parser.parseModule dflags stmt of
889 Lexer.POk _ thing -> hasImports thing
890 Lexer.PFailed _ -> False
891 where
892 hasImports = not . null . hsmodImports . unLoc
893
894 -- | Returns @True@ if passed string is an import declaration.
895 isImport :: DynFlags -> String -> Bool
896 isImport dflags stmt =
897 case parseThing Parser.parseImport dflags stmt of
898 Lexer.POk _ _ -> True
899 Lexer.PFailed _ -> False
900
901 -- | Returns @True@ if passed string is a declaration but __/not a splice/__.
902 isDecl :: DynFlags -> String -> Bool
903 isDecl dflags stmt = do
904 case parseThing Parser.parseDeclaration dflags stmt of
905 Lexer.POk _ thing ->
906 case unLoc thing of
907 SpliceD _ _ -> False
908 _ -> True
909 Lexer.PFailed _ -> False
910
911 parseThing :: Lexer.P thing -> DynFlags -> String -> Lexer.ParseResult thing
912 parseThing parser dflags stmt = do
913 let buf = stringToStringBuffer stmt
914 loc = mkRealSrcLoc (fsLit "<interactive>") 1 1
915
916 Lexer.unP parser (Lexer.mkPState dflags buf loc)
917
918 getDocs :: GhcMonad m
919 => Name
920 -> m (Either GetDocsFailure (Maybe HsDocString, Map Int HsDocString))
921 -- TODO: What about docs for constructors etc.?
922 getDocs name =
923 withSession $ \hsc_env -> do
924 case nameModule_maybe name of
925 Nothing -> pure (Left (NameHasNoModule name))
926 Just mod -> do
927 if isInteractiveModule mod
928 then pure (Left InteractiveName)
929 else do
930 ModIface { mi_doc_hdr = mb_doc_hdr
931 , mi_decl_docs = DeclDocMap dmap
932 , mi_arg_docs = ArgDocMap amap
933 } <- liftIO $ hscGetModuleInterface hsc_env mod
934 if isNothing mb_doc_hdr && Map.null dmap && Map.null amap
935 then pure (Left (NoDocsInIface mod compiled))
936 else pure (Right ( Map.lookup name dmap
937 , Map.findWithDefault Map.empty name amap))
938 where
939 compiled =
940 -- TODO: Find a more direct indicator.
941 case nameSrcLoc name of
942 RealSrcLoc {} -> False
943 UnhelpfulLoc {} -> True
944
945 -- | Failure modes for 'getDocs'.
946
947 -- TODO: Find a way to differentiate between modules loaded without '-haddock'
948 -- and modules that contain no docs.
949 data GetDocsFailure
950
951 -- | 'nameModule_maybe' returned 'Nothing'.
952 = NameHasNoModule Name
953
954 -- | This is probably because the module was loaded without @-haddock@,
955 -- but it's also possible that the entire module contains no documentation.
956 | NoDocsInIface
957 Module
958 Bool -- ^ 'True': The module was compiled.
959 -- 'False': The module was :loaded.
960
961 -- | The 'Name' was defined interactively.
962 | InteractiveName
963
964 instance Outputable GetDocsFailure where
965 ppr (NameHasNoModule name) =
966 quotes (ppr name) <+> text "has no module where we could look for docs."
967 ppr (NoDocsInIface mod compiled) = vcat
968 [ text "Can't find any documentation for" <+> ppr mod <> char '.'
969 , text "This is probably because the module was"
970 <+> text (if compiled then "compiled" else "loaded")
971 <+> text "without '-haddock',"
972 , text "but it's also possible that the module contains no documentation."
973 , text ""
974 , if compiled
975 then text "Try re-compiling with '-haddock'."
976 else text "Try running ':set -haddock' and :load the file again."
977 -- TODO: Figure out why :reload doesn't load the docs and maybe fix it.
978 ]
979 ppr InteractiveName =
980 text "Docs are unavailable for interactive declarations."
981
982 -- -----------------------------------------------------------------------------
983 -- Getting the type of an expression
984
985 -- | Get the type of an expression
986 -- Returns the type as described by 'TcRnExprMode'
987 exprType :: GhcMonad m => TcRnExprMode -> String -> m Type
988 exprType mode expr = withSession $ \hsc_env -> do
989 ty <- liftIO $ hscTcExpr hsc_env mode expr
990 return $ tidyType emptyTidyEnv ty
991
992 -- -----------------------------------------------------------------------------
993 -- Getting the kind of a type
994
995 -- | Get the kind of a type
996 typeKind :: GhcMonad m => Bool -> String -> m (Type, Kind)
997 typeKind normalise str = withSession $ \hsc_env -> do
998 liftIO $ hscKcType hsc_env normalise str
999
1000 -- ----------------------------------------------------------------------------
1001 -- Getting the class instances for a type
1002
1003 {-
1004 Note [Querying instances for a type]
1005
1006 Here is the implementation of GHC proposal 41.
1007 (https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0041-ghci-instances.rst)
1008
1009 The objective is to take a query string representing a (partial) type, and
1010 report all the class single-parameter class instances available to that type.
1011 Extending this feature to multi-parameter typeclasses is left as future work.
1012
1013 The general outline of how we solve this is:
1014
1015 1. Parse the type, leaving skolems in the place of type-holes.
1016 2. For every class, get a list of all instances that match with the query type.
1017 3. For every matching instance, ask GHC for the context the instance dictionary needs.
1018 4. Format and present the results, substituting our query into the instance
1019 and simplifying the context.
1020
1021 For example, given the query "Maybe Int", we want to return:
1022
1023 instance Show (Maybe Int)
1024 instance Read (Maybe Int)
1025 instance Eq (Maybe Int)
1026 ....
1027
1028 [Holes in queries]
1029
1030 Often times we want to know what instances are available for a polymorphic type,
1031 like `Maybe a`, and we'd like to return instances such as:
1032
1033 instance Show a => Show (Maybe a)
1034 ....
1035
1036 These queries are expressed using type holes, so instead of `Maybe a` the user writes
1037 `Maybe _`, we parse the type and during zonking, we skolemise it, replacing the holes
1038 with (un-named) type variables.
1039
1040 When zonking the type holes we have two real choices: replace them with Any or replace
1041 them with skolem typevars. Using skolem type variables ensures that the output is more
1042 intuitive to end users, and there is no difference in the results between Any and skolems.
1043
1044 -}
1045
1046 -- Find all instances that match a provided type
1047 getInstancesForType :: GhcMonad m => Type -> m [ClsInst]
1048 getInstancesForType ty = withSession $ \hsc_env -> do
1049 liftIO $ runInteractiveHsc hsc_env $ do
1050 ioMsgMaybe $ runTcInteractive hsc_env $ do
1051 matches <- findMatchingInstances ty
1052 fmap catMaybes . forM matches $ uncurry checkForExistence
1053
1054 -- Parse a type string and turn any holes into skolems
1055 parseInstanceHead :: GhcMonad m => String -> m Type
1056 parseInstanceHead str = withSession $ \hsc_env0 -> do
1057 (ty, _) <- liftIO $ runInteractiveHsc hsc_env0 $ do
1058 hsc_env <- getHscEnv
1059 ty <- hscParseType str
1060 ioMsgMaybe $ tcRnType hsc_env SkolemiseFlexi True ty
1061
1062 return ty
1063
1064 -- Get all the constraints required of a dictionary binding
1065 getDictionaryBindings :: PredType -> TcM WantedConstraints
1066 getDictionaryBindings theta = do
1067 dictName <- newName (mkDictOcc (mkVarOcc "magic"))
1068 let dict_var = mkVanillaGlobal dictName theta
1069 loc <- getCtLocM (GivenOrigin UnkSkol) Nothing
1070 let wCs = mkSimpleWC [CtDerived
1071 { ctev_pred = varType dict_var
1072 , ctev_loc = loc
1073 }]
1074
1075 return wCs
1076
1077 {-
1078 When we've found an instance that a query matches against, we still need to
1079 check that all the instance's constraints are satisfiable. checkForExistence
1080 creates an instance dictionary and verifies that any unsolved constraints
1081 mention a type-hole, meaning it is blocked on an unknown.
1082
1083 If the instance satisfies this condition, then we return it with the query
1084 substituted into the instance and all constraints simplified, for example given:
1085
1086 instance D a => C (MyType a b) where
1087
1088 and the query `MyType _ String`
1089
1090 the unsolved constraints will be [D _] so we apply the substitution:
1091
1092 { a -> _; b -> String}
1093
1094 and return the instance:
1095
1096 instance D _ => C (MyType _ String)
1097
1098 -}
1099
1100 checkForExistence :: ClsInst -> [DFunInstType] -> TcM (Maybe ClsInst)
1101 checkForExistence res mb_inst_tys = do
1102 (tys, thetas) <- instDFunType (is_dfun res) mb_inst_tys
1103
1104 wanteds <- forM thetas getDictionaryBindings
1105 (residuals, _) <- second evBindMapBinds <$> runTcS (solveWanteds (unionsWC wanteds))
1106
1107 let all_residual_constraints = bagToList $ wc_simple residuals
1108 let preds = map ctPred all_residual_constraints
1109 if all isSatisfiablePred preds && (null $ wc_impl residuals)
1110 then return . Just $ substInstArgs tys preds res
1111 else return Nothing
1112
1113 where
1114
1115 -- Stricter version of isTyVarClassPred that requires all TyConApps to have at least
1116 -- one argument or for the head to be a TyVar. The reason is that we want to ensure
1117 -- that all residual constraints mention a type-hole somewhere in the constraint,
1118 -- meaning that with the correct choice of a concrete type it could be possible for
1119 -- the constraint to be discharged.
1120 isSatisfiablePred :: PredType -> Bool
1121 isSatisfiablePred ty = case getClassPredTys_maybe ty of
1122 Just (_, tys@(_:_)) -> all isTyVarTy tys
1123 _ -> isTyVarTy ty
1124
1125 empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType (idType $ is_dfun res)))
1126
1127 {- Create a ClsInst with instantiated arguments and constraints.
1128
1129 The thetas are the list of constraints that couldn't be solved because
1130 they mention a type-hole.
1131 -}
1132 substInstArgs :: [Type] -> [PredType] -> ClsInst -> ClsInst
1133 substInstArgs tys thetas inst = let
1134 subst = foldl' (\a b -> uncurry (extendTvSubstAndInScope a) b) empty_subst (zip dfun_tvs tys)
1135 -- Build instance head with arguments substituted in
1136 tau = mkClassPred cls (substTheta subst args)
1137 -- Constrain the instance with any residual constraints
1138 phi = mkPhiTy thetas tau
1139 sigma = mkForAllTys (map (\v -> Bndr v Inferred) dfun_tvs) phi
1140
1141 in inst { is_dfun = (is_dfun inst) { varType = sigma }}
1142 where
1143 (dfun_tvs, _, cls, args) = instanceSig inst
1144
1145 -- Find instances where the head unifies with the provided type
1146 findMatchingInstances :: Type -> TcM [(ClsInst, [DFunInstType])]
1147 findMatchingInstances ty = do
1148 ies@(InstEnvs {ie_global = ie_global, ie_local = ie_local}) <- tcGetInstEnvs
1149 let allClasses = instEnvClasses ie_global ++ instEnvClasses ie_local
1150
1151 concat <$> mapM (\cls -> do
1152 let (matches, _, _) = lookupInstEnv True ies cls [ty]
1153 return matches) allClasses
1154
1155 -----------------------------------------------------------------------------
1156 -- Compile an expression, run it, and deliver the result
1157
1158 -- | Parse an expression, the parsed expression can be further processed and
1159 -- passed to compileParsedExpr.
1160 parseExpr :: GhcMonad m => String -> m (LHsExpr GhcPs)
1161 parseExpr expr = withSession $ \hsc_env -> do
1162 liftIO $ runInteractiveHsc hsc_env $ hscParseExpr expr
1163
1164 -- | Compile an expression, run it, and deliver the resulting HValue.
1165 compileExpr :: GhcMonad m => String -> m HValue
1166 compileExpr expr = do
1167 parsed_expr <- parseExpr expr
1168 compileParsedExpr parsed_expr
1169
1170 -- | Compile an expression, run it, and deliver the resulting HValue.
1171 compileExprRemote :: GhcMonad m => String -> m ForeignHValue
1172 compileExprRemote expr = do
1173 parsed_expr <- parseExpr expr
1174 compileParsedExprRemote parsed_expr
1175
1176 -- | Compile a parsed expression (before renaming), run it, and deliver
1177 -- the resulting HValue.
1178 compileParsedExprRemote :: GhcMonad m => LHsExpr GhcPs -> m ForeignHValue
1179 compileParsedExprRemote expr@(L loc _) = withSession $ \hsc_env -> do
1180 -- > let _compileParsedExpr = expr
1181 -- Create let stmt from expr to make hscParsedStmt happy.
1182 -- We will ignore the returned [Id], namely [expr_id], and not really
1183 -- create a new binding.
1184 let expr_fs = fsLit "_compileParsedExpr"
1185 expr_name = mkInternalName (getUnique expr_fs) (mkTyVarOccFS expr_fs) loc
1186 let_stmt = L loc . LetStmt noExtField . L loc . (HsValBinds noExtField) $
1187 ValBinds noExtField
1188 (unitBag $ mkHsVarBind loc (getRdrName expr_name) expr) []
1189
1190 pstmt <- liftIO $ hscParsedStmt hsc_env let_stmt
1191 let (hvals_io, fix_env) = case pstmt of
1192 Just ([_id], hvals_io', fix_env') -> (hvals_io', fix_env')
1193 _ -> panic "compileParsedExprRemote"
1194
1195 updateFixityEnv fix_env
1196 status <- liftIO $ evalStmt hsc_env False (EvalThis hvals_io)
1197 case status of
1198 EvalComplete _ (EvalSuccess [hval]) -> return hval
1199 EvalComplete _ (EvalException e) ->
1200 liftIO $ throwIO (fromSerializableException e)
1201 _ -> panic "compileParsedExpr"
1202
1203 compileParsedExpr :: GhcMonad m => LHsExpr GhcPs -> m HValue
1204 compileParsedExpr expr = do
1205 fhv <- compileParsedExprRemote expr
1206 dflags <- getDynFlags
1207 liftIO $ wormhole dflags fhv
1208
1209 -- | Compile an expression, run it and return the result as a Dynamic.
1210 dynCompileExpr :: GhcMonad m => String -> m Dynamic
1211 dynCompileExpr expr = do
1212 parsed_expr <- parseExpr expr
1213 -- > Data.Dynamic.toDyn expr
1214 let loc = getLoc parsed_expr
1215 to_dyn_expr = mkHsApp (L loc . HsVar noExtField . L loc $ getRdrName toDynName)
1216 parsed_expr
1217 hval <- compileParsedExpr to_dyn_expr
1218 return (unsafeCoerce# hval :: Dynamic)
1219
1220 -----------------------------------------------------------------------------
1221 -- show a module and it's source/object filenames
1222
1223 showModule :: GhcMonad m => ModSummary -> m String
1224 showModule mod_summary =
1225 withSession $ \hsc_env -> do
1226 interpreted <- moduleIsBootOrNotObjectLinkable mod_summary
1227 let dflags = hsc_dflags hsc_env
1228 return (showModMsg dflags (hscTarget dflags) interpreted mod_summary)
1229
1230 moduleIsBootOrNotObjectLinkable :: GhcMonad m => ModSummary -> m Bool
1231 moduleIsBootOrNotObjectLinkable mod_summary = withSession $ \hsc_env ->
1232 case lookupHpt (hsc_HPT hsc_env) (ms_mod_name mod_summary) of
1233 Nothing -> panic "missing linkable"
1234 Just mod_info -> return $ case hm_linkable mod_info of
1235 Nothing -> True
1236 Just linkable -> not (isObjectLinkable linkable)
1237
1238 ----------------------------------------------------------------------------
1239 -- RTTI primitives
1240
1241 obtainTermFromVal :: HscEnv -> Int -> Bool -> Type -> a -> IO Term
1242 obtainTermFromVal hsc_env bound force ty x
1243 | gopt Opt_ExternalInterpreter (hsc_dflags hsc_env)
1244 = throwIO (InstallationError
1245 "this operation requires -fno-external-interpreter")
1246 | otherwise
1247 = cvObtainTerm hsc_env bound force ty (unsafeCoerce# x)
1248
1249 obtainTermFromId :: HscEnv -> Int -> Bool -> Id -> IO Term
1250 obtainTermFromId hsc_env bound force id = do
1251 hv <- Linker.getHValue hsc_env (varName id)
1252 cvObtainTerm hsc_env bound force (idType id) hv
1253
1254 -- Uses RTTI to reconstruct the type of an Id, making it less polymorphic
1255 reconstructType :: HscEnv -> Int -> Id -> IO (Maybe Type)
1256 reconstructType hsc_env bound id = do
1257 hv <- Linker.getHValue hsc_env (varName id)
1258 cvReconstructType hsc_env bound (idType id) hv
1259
1260 mkRuntimeUnkTyVar :: Name -> Kind -> TyVar
1261 mkRuntimeUnkTyVar name kind = mkTcTyVar name kind RuntimeUnk