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