Remove some horrible munging of origins for Coercible
[ghc.git] / compiler / typecheck / Inst.hs
1 {-
2 (c) The University of Glasgow 2006
3 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4
5
6 The @Inst@ type: dictionaries or method instances
7 -}
8
9 {-# LANGUAGE CPP #-}
10
11 module Inst (
12 deeplySkolemise, deeplyInstantiate,
13 instCall, instDFunType, instStupidTheta,
14 newWanted, newWanteds,
15 emitWanted, emitWanteds,
16
17 newOverloadedLit, mkOverLit,
18
19 newClsInst,
20 tcGetInsts, tcGetInstEnvs, getOverlapFlag,
21 tcExtendLocalInstEnv, instCallConstraints, newMethodFromName,
22 tcSyntaxName,
23
24 -- Simple functions over evidence variables
25 tyVarsOfWC, tyVarsOfBag,
26 tyVarsOfCt, tyVarsOfCts,
27 ) where
28
29 #include "HsVersions.h"
30
31 import {-# SOURCE #-} TcExpr( tcPolyExpr, tcSyntaxOp )
32 import {-# SOURCE #-} TcUnify( unifyType )
33
34 import FastString
35 import HsSyn
36 import TcHsSyn
37 import TcRnMonad
38 import TcEnv
39 import TcEvidence
40 import InstEnv
41 import FunDeps
42 import TcMType
43 import Type
44 import Coercion ( Role(..) )
45 import TcType
46 import HscTypes
47 import Class( Class )
48 import MkId( mkDictFunId )
49 import Id
50 import Name
51 import Var ( EvVar )
52 import VarEnv
53 import VarSet
54 import PrelNames
55 import SrcLoc
56 import DynFlags
57 import Bag
58 import Util
59 import Outputable
60 import Control.Monad( unless )
61 import Data.Maybe( isJust )
62
63 {-
64 ************************************************************************
65 * *
66 Creating and emittind constraints
67 * *
68 ************************************************************************
69 -}
70
71 newWanted :: CtOrigin -> PredType -> TcM CtEvidence
72 newWanted orig pty
73 = do loc <- getCtLocM orig
74 v <- newEvVar pty
75 return $ CtWanted { ctev_evar = v
76 , ctev_pred = pty
77 , ctev_loc = loc }
78
79 newWanteds :: CtOrigin -> ThetaType -> TcM [CtEvidence]
80 newWanteds orig = mapM (newWanted orig)
81
82 emitWanteds :: CtOrigin -> TcThetaType -> TcM [EvVar]
83 emitWanteds origin theta = mapM (emitWanted origin) theta
84
85 emitWanted :: CtOrigin -> TcPredType -> TcM EvVar
86 emitWanted origin pred
87 = do { loc <- getCtLocM origin
88 ; ev <- newEvVar pred
89 ; emitSimple $ mkNonCanonical $
90 CtWanted { ctev_pred = pred, ctev_evar = ev, ctev_loc = loc }
91 ; return ev }
92
93 newMethodFromName :: CtOrigin -> Name -> TcRhoType -> TcM (HsExpr TcId)
94 -- Used when Name is the wired-in name for a wired-in class method,
95 -- so the caller knows its type for sure, which should be of form
96 -- forall a. C a => <blah>
97 -- newMethodFromName is supposed to instantiate just the outer
98 -- type variable and constraint
99
100 newMethodFromName origin name inst_ty
101 = do { id <- tcLookupId name
102 -- Use tcLookupId not tcLookupGlobalId; the method is almost
103 -- always a class op, but with -XRebindableSyntax GHC is
104 -- meant to find whatever thing is in scope, and that may
105 -- be an ordinary function.
106
107 ; let (tvs, theta, _caller_knows_this) = tcSplitSigmaTy (idType id)
108 (the_tv:rest) = tvs
109 subst = zipOpenTvSubst [the_tv] [inst_ty]
110
111 ; wrap <- ASSERT( null rest && isSingleton theta )
112 instCall origin [inst_ty] (substTheta subst theta)
113 ; return (mkHsWrap wrap (HsVar id)) }
114
115 {-
116 ************************************************************************
117 * *
118 Deep instantiation and skolemisation
119 * *
120 ************************************************************************
121
122 Note [Deep skolemisation]
123 ~~~~~~~~~~~~~~~~~~~~~~~~~
124 deeplySkolemise decomposes and skolemises a type, returning a type
125 with all its arrows visible (ie not buried under foralls)
126
127 Examples:
128
129 deeplySkolemise (Int -> forall a. Ord a => blah)
130 = ( wp, [a], [d:Ord a], Int -> blah )
131 where wp = \x:Int. /\a. \(d:Ord a). <hole> x
132
133 deeplySkolemise (forall a. Ord a => Maybe a -> forall b. Eq b => blah)
134 = ( wp, [a,b], [d1:Ord a,d2:Eq b], Maybe a -> blah )
135 where wp = /\a.\(d1:Ord a).\(x:Maybe a)./\b.\(d2:Ord b). <hole> x
136
137 In general,
138 if deeplySkolemise ty = (wrap, tvs, evs, rho)
139 and e :: rho
140 then wrap e :: ty
141 and 'wrap' binds tvs, evs
142
143 ToDo: this eta-abstraction plays fast and loose with termination,
144 because it can introduce extra lambdas. Maybe add a `seq` to
145 fix this
146 -}
147
148 deeplySkolemise
149 :: TcSigmaType
150 -> TcM (HsWrapper, [TyVar], [EvVar], TcRhoType)
151
152 deeplySkolemise ty
153 | Just (arg_tys, tvs, theta, ty') <- tcDeepSplitSigmaTy_maybe ty
154 = do { ids1 <- newSysLocalIds (fsLit "dk") arg_tys
155 ; (subst, tvs1) <- tcInstSkolTyVars tvs
156 ; ev_vars1 <- newEvVars (substTheta subst theta)
157 ; (wrap, tvs2, ev_vars2, rho) <- deeplySkolemise (substTy subst ty')
158 ; return ( mkWpLams ids1
159 <.> mkWpTyLams tvs1
160 <.> mkWpLams ev_vars1
161 <.> wrap
162 <.> mkWpEvVarApps ids1
163 , tvs1 ++ tvs2
164 , ev_vars1 ++ ev_vars2
165 , mkFunTys arg_tys rho ) }
166
167 | otherwise
168 = return (idHsWrapper, [], [], ty)
169
170 deeplyInstantiate :: CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType)
171 -- Int -> forall a. a -> a ==> (\x:Int. [] x alpha) :: Int -> alpha
172 -- In general if
173 -- if deeplyInstantiate ty = (wrap, rho)
174 -- and e :: ty
175 -- then wrap e :: rho
176
177 deeplyInstantiate orig ty
178 | Just (arg_tys, tvs, theta, rho) <- tcDeepSplitSigmaTy_maybe ty
179 = do { (subst, tvs') <- tcInstTyVars tvs
180 ; ids1 <- newSysLocalIds (fsLit "di") (substTys subst arg_tys)
181 ; let theta' = substTheta subst theta
182 ; wrap1 <- instCall orig (mkTyVarTys tvs') theta'
183 ; traceTc "Instantiating (deeply)" (vcat [ text "origin" <+> pprCtOrigin orig
184 , text "type" <+> ppr ty
185 , text "with" <+> ppr tvs'
186 , text "args:" <+> ppr ids1
187 , text "theta:" <+> ppr theta' ])
188 ; (wrap2, rho2) <- deeplyInstantiate orig (substTy subst rho)
189 ; return (mkWpLams ids1
190 <.> wrap2
191 <.> wrap1
192 <.> mkWpEvVarApps ids1,
193 mkFunTys arg_tys rho2) }
194
195 | otherwise = return (idHsWrapper, ty)
196
197 {-
198 ************************************************************************
199 * *
200 Instantiating a call
201 * *
202 ************************************************************************
203 -}
204
205 ----------------
206 instCall :: CtOrigin -> [TcType] -> TcThetaType -> TcM HsWrapper
207 -- Instantiate the constraints of a call
208 -- (instCall o tys theta)
209 -- (a) Makes fresh dictionaries as necessary for the constraints (theta)
210 -- (b) Throws these dictionaries into the LIE
211 -- (c) Returns an HsWrapper ([.] tys dicts)
212
213 instCall orig tys theta
214 = do { dict_app <- instCallConstraints orig theta
215 ; return (dict_app <.> mkWpTyApps tys) }
216
217 ----------------
218 instCallConstraints :: CtOrigin -> TcThetaType -> TcM HsWrapper
219 -- Instantiates the TcTheta, puts all constraints thereby generated
220 -- into the LIE, and returns a HsWrapper to enclose the call site.
221
222 instCallConstraints orig preds
223 | null preds
224 = return idHsWrapper
225 | otherwise
226 = do { evs <- mapM go preds
227 ; traceTc "instCallConstraints" (ppr evs)
228 ; return (mkWpEvApps evs) }
229 where
230 go pred
231 | Just (Nominal, ty1, ty2) <- getEqPredTys_maybe pred -- Try short-cut
232 = do { co <- unifyType ty1 ty2
233 ; return (EvCoercion co) }
234 | otherwise
235 = do { ev_var <- emitWanted orig pred
236 ; return (EvId ev_var) }
237
238 instDFunType :: DFunId -> [DFunInstType] -> TcM ([TcType], TcThetaType)
239 -- See Note [DFunInstType: instantiating types] in InstEnv
240 instDFunType dfun_id dfun_inst_tys
241 = do { (subst, inst_tys) <- go (mkTopTvSubst []) dfun_tvs dfun_inst_tys
242 ; return (inst_tys, substTheta subst dfun_theta) }
243 where
244 (dfun_tvs, dfun_theta, _) = tcSplitSigmaTy (idType dfun_id)
245
246 go :: TvSubst -> [TyVar] -> [DFunInstType] -> TcM (TvSubst, [TcType])
247 go subst [] [] = return (subst, [])
248 go subst (tv:tvs) (Just ty : mb_tys)
249 = do { (subst', tys) <- go (extendTvSubst subst tv ty) tvs mb_tys
250 ; return (subst', ty : tys) }
251 go subst (tv:tvs) (Nothing : mb_tys)
252 = do { (subst', tv') <- tcInstTyVarX subst tv
253 ; (subst'', tys) <- go subst' tvs mb_tys
254 ; return (subst'', mkTyVarTy tv' : tys) }
255 go _ _ _ = pprPanic "instDFunTypes" (ppr dfun_id $$ ppr dfun_inst_tys)
256
257 ----------------
258 instStupidTheta :: CtOrigin -> TcThetaType -> TcM ()
259 -- Similar to instCall, but only emit the constraints in the LIE
260 -- Used exclusively for the 'stupid theta' of a data constructor
261 instStupidTheta orig theta
262 = do { _co <- instCallConstraints orig theta -- Discard the coercion
263 ; return () }
264
265 {-
266 ************************************************************************
267 * *
268 Literals
269 * *
270 ************************************************************************
271
272 In newOverloadedLit we convert directly to an Int or Integer if we
273 know that's what we want. This may save some time, by not
274 temporarily generating overloaded literals, but it won't catch all
275 cases (the rest are caught in lookupInst).
276 -}
277
278 newOverloadedLit :: CtOrigin
279 -> HsOverLit Name
280 -> TcRhoType
281 -> TcM (HsOverLit TcId)
282 newOverloadedLit orig lit res_ty
283 = do dflags <- getDynFlags
284 newOverloadedLit' dflags orig lit res_ty
285
286 newOverloadedLit' :: DynFlags
287 -> CtOrigin
288 -> HsOverLit Name
289 -> TcRhoType
290 -> TcM (HsOverLit TcId)
291 newOverloadedLit' dflags orig
292 lit@(OverLit { ol_val = val, ol_rebindable = rebindable
293 , ol_witness = meth_name }) res_ty
294
295 | not rebindable
296 , Just expr <- shortCutLit dflags val res_ty
297 -- Do not generate a LitInst for rebindable syntax.
298 -- Reason: If we do, tcSimplify will call lookupInst, which
299 -- will call tcSyntaxName, which does unification,
300 -- which tcSimplify doesn't like
301 = return (lit { ol_witness = expr, ol_type = res_ty
302 , ol_rebindable = rebindable })
303
304 | otherwise
305 = do { hs_lit <- mkOverLit val
306 ; let lit_ty = hsLitType hs_lit
307 ; fi' <- tcSyntaxOp orig meth_name (mkFunTy lit_ty res_ty)
308 -- Overloaded literals must have liftedTypeKind, because
309 -- we're instantiating an overloaded function here,
310 -- whereas res_ty might be openTypeKind. This was a bug in 6.2.2
311 -- However this'll be picked up by tcSyntaxOp if necessary
312 ; let witness = HsApp (noLoc fi') (noLoc (HsLit hs_lit))
313 ; return (lit { ol_witness = witness, ol_type = res_ty
314 , ol_rebindable = rebindable }) }
315
316 ------------
317 mkOverLit :: OverLitVal -> TcM HsLit
318 mkOverLit (HsIntegral src i)
319 = do { integer_ty <- tcMetaTy integerTyConName
320 ; return (HsInteger src i integer_ty) }
321
322 mkOverLit (HsFractional r)
323 = do { rat_ty <- tcMetaTy rationalTyConName
324 ; return (HsRat r rat_ty) }
325
326 mkOverLit (HsIsString src s) = return (HsString src s)
327
328 {-
329 ************************************************************************
330 * *
331 Re-mappable syntax
332
333 Used only for arrow syntax -- find a way to nuke this
334 * *
335 ************************************************************************
336
337 Suppose we are doing the -XRebindableSyntax thing, and we encounter
338 a do-expression. We have to find (>>) in the current environment, which is
339 done by the rename. Then we have to check that it has the same type as
340 Control.Monad.(>>). Or, more precisely, a compatible type. One 'customer' had
341 this:
342
343 (>>) :: HB m n mn => m a -> n b -> mn b
344
345 So the idea is to generate a local binding for (>>), thus:
346
347 let then72 :: forall a b. m a -> m b -> m b
348 then72 = ...something involving the user's (>>)...
349 in
350 ...the do-expression...
351
352 Now the do-expression can proceed using then72, which has exactly
353 the expected type.
354
355 In fact tcSyntaxName just generates the RHS for then72, because we only
356 want an actual binding in the do-expression case. For literals, we can
357 just use the expression inline.
358 -}
359
360 tcSyntaxName :: CtOrigin
361 -> TcType -- Type to instantiate it at
362 -> (Name, HsExpr Name) -- (Standard name, user name)
363 -> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression)
364 -- USED ONLY FOR CmdTop (sigh) ***
365 -- See Note [CmdSyntaxTable] in HsExpr
366
367 tcSyntaxName orig ty (std_nm, HsVar user_nm)
368 | std_nm == user_nm
369 = do rhs <- newMethodFromName orig std_nm ty
370 return (std_nm, rhs)
371
372 tcSyntaxName orig ty (std_nm, user_nm_expr) = do
373 std_id <- tcLookupId std_nm
374 let
375 -- C.f. newMethodAtLoc
376 ([tv], _, tau) = tcSplitSigmaTy (idType std_id)
377 sigma1 = substTyWith [tv] [ty] tau
378 -- Actually, the "tau-type" might be a sigma-type in the
379 -- case of locally-polymorphic methods.
380
381 addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $ do
382
383 -- Check that the user-supplied thing has the
384 -- same type as the standard one.
385 -- Tiresome jiggling because tcCheckSigma takes a located expression
386 span <- getSrcSpanM
387 expr <- tcPolyExpr (L span user_nm_expr) sigma1
388 return (std_nm, unLoc expr)
389
390 syntaxNameCtxt :: HsExpr Name -> CtOrigin -> Type -> TidyEnv
391 -> TcRn (TidyEnv, SDoc)
392 syntaxNameCtxt name orig ty tidy_env
393 = do { inst_loc <- getCtLocM orig
394 ; let msg = vcat [ ptext (sLit "When checking that") <+> quotes (ppr name)
395 <+> ptext (sLit "(needed by a syntactic construct)")
396 , nest 2 (ptext (sLit "has the required type:")
397 <+> ppr (tidyType tidy_env ty))
398 , nest 2 (pprCtLoc inst_loc) ]
399 ; return (tidy_env, msg) }
400
401 {-
402 ************************************************************************
403 * *
404 Instances
405 * *
406 ************************************************************************
407 -}
408
409 getOverlapFlag :: Maybe OverlapMode -> TcM OverlapFlag
410 getOverlapFlag overlap_mode
411 = do { dflags <- getDynFlags
412 ; let overlap_ok = xopt Opt_OverlappingInstances dflags
413 incoherent_ok = xopt Opt_IncoherentInstances dflags
414 use x = OverlapFlag { isSafeOverlap = safeLanguageOn dflags
415 , overlapMode = x }
416 default_oflag | incoherent_ok = use (Incoherent "")
417 | overlap_ok = use (Overlaps "")
418 | otherwise = use (NoOverlap "")
419
420 final_oflag = setOverlapModeMaybe default_oflag overlap_mode
421 ; return final_oflag }
422
423 tcGetInsts :: TcM [ClsInst]
424 -- Gets the local class instances.
425 tcGetInsts = fmap tcg_insts getGblEnv
426
427 newClsInst :: Maybe OverlapMode -> Name -> [TyVar] -> ThetaType
428 -> Class -> [Type] -> TcM ClsInst
429 newClsInst overlap_mode dfun_name tvs theta clas tys
430 = do { (subst, tvs') <- freshenTyVarBndrs tvs
431 -- Be sure to freshen those type variables,
432 -- so they are sure not to appear in any lookup
433 ; let tys' = substTys subst tys
434 theta' = substTheta subst theta
435 dfun = mkDictFunId dfun_name tvs' theta' clas tys'
436 -- Substituting in the DFun type just makes sure that
437 -- we are using TyVars rather than TcTyVars
438 -- Not sure if this is really the right place to do so,
439 -- but it'll do fine
440 ; oflag <- getOverlapFlag overlap_mode
441 ; return (mkLocalInstance dfun oflag tvs' clas tys') }
442
443 tcExtendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a
444 -- Add new locally-defined instances
445 tcExtendLocalInstEnv dfuns thing_inside
446 = do { traceDFuns dfuns
447 ; env <- getGblEnv
448 ; (inst_env', cls_insts') <- foldlM addLocalInst
449 (tcg_inst_env env, tcg_insts env)
450 dfuns
451 ; let env' = env { tcg_insts = cls_insts'
452 , tcg_inst_env = inst_env' }
453 ; setGblEnv env' thing_inside }
454
455 addLocalInst :: (InstEnv, [ClsInst]) -> ClsInst -> TcM (InstEnv, [ClsInst])
456 -- Check that the proposed new instance is OK,
457 -- and then add it to the home inst env
458 -- If overwrite_inst, then we can overwrite a direct match
459 addLocalInst (home_ie, my_insts) ispec
460 = do {
461 -- Instantiate the dfun type so that we extend the instance
462 -- envt with completely fresh template variables
463 -- This is important because the template variables must
464 -- not overlap with anything in the things being looked up
465 -- (since we do unification).
466 --
467 -- We use tcInstSkolType because we don't want to allocate fresh
468 -- *meta* type variables.
469 --
470 -- We use UnkSkol --- and *not* InstSkol or PatSkol --- because
471 -- these variables must be bindable by tcUnifyTys. See
472 -- the call to tcUnifyTys in InstEnv, and the special
473 -- treatment that instanceBindFun gives to isOverlappableTyVar
474 -- This is absurdly delicate.
475
476 -- Load imported instances, so that we report
477 -- duplicates correctly
478
479 -- 'matches' are existing instance declarations that are less
480 -- specific than the new one
481 -- 'dups' are those 'matches' that are equal to the new one
482 ; isGHCi <- getIsGHCi
483 ; eps <- getEps
484 ; tcg_env <- getGblEnv
485
486 -- In GHCi, we *override* any identical instances
487 -- that are also defined in the interactive context
488 -- See Note [Override identical instances in GHCi]
489 ; let home_ie'
490 | isGHCi = deleteFromInstEnv home_ie ispec
491 | otherwise = home_ie
492
493 (_tvs, cls, tys) = instanceHead ispec
494 -- If we're compiling sig-of and there's an external duplicate
495 -- instance, silently ignore it (that's the instance we're
496 -- implementing!) NB: we still count local duplicate instances
497 -- as errors.
498 -- See Note [Signature files and type class instances]
499 global_ie
500 | isJust (tcg_sig_of tcg_env) = emptyInstEnv
501 | otherwise = eps_inst_env eps
502 inst_envs = InstEnvs { ie_global = global_ie
503 , ie_local = home_ie'
504 , ie_visible = tcVisibleOrphanMods tcg_env }
505 (matches, _, _) = lookupInstEnv False inst_envs cls tys
506 dups = filter (identicalClsInstHead ispec) (map fst matches)
507
508 -- Check functional dependencies
509 ; case checkFunDeps inst_envs ispec of
510 Just specs -> funDepErr ispec specs
511 Nothing -> return ()
512
513 -- Check for duplicate instance decls.
514 ; unless (null dups) $
515 dupInstErr ispec (head dups)
516
517 ; return (extendInstEnv home_ie' ispec, ispec : my_insts) }
518
519 {-
520 Note [Signature files and type class instances]
521 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
522 Instances in signature files do not have an effect when compiling:
523 when you compile a signature against an implementation, you will
524 see the instances WHETHER OR NOT the instance is declared in
525 the file (this is because the signatures go in the EPS and we
526 can't filter them out easily.) This is also why we cannot
527 place the instance in the hi file: it would show up as a duplicate,
528 and we don't have instance reexports anyway.
529
530 However, you might find them useful when typechecking against
531 a signature: the instance is a way of indicating to GHC that
532 some instance exists, in case downstream code uses it.
533
534 Implementing this is a little tricky. Consider the following
535 situation (sigof03):
536
537 module A where
538 instance C T where ...
539
540 module ASig where
541 instance C T
542
543 When compiling ASig, A.hi is loaded, which brings its instances
544 into the EPS. When we process the instance declaration in ASig,
545 we should ignore it for the purpose of doing a duplicate check,
546 since it's not actually a duplicate. But don't skip the check
547 entirely, we still want this to fail (tcfail221):
548
549 module ASig where
550 instance C T
551 instance C T
552
553 Note that in some situations, the interface containing the type
554 class instances may not have been loaded yet at all. The usual
555 situation when A imports another module which provides the
556 instances (sigof02m):
557
558 module A(module B) where
559 import B
560
561 See also Note [Signature lazy interface loading]. We can't
562 rely on this, however, since sometimes we'll have spurious
563 type class instances in the EPS, see #9422 (sigof02dm)
564
565 ************************************************************************
566 * *
567 Errors and tracing
568 * *
569 ************************************************************************
570 -}
571
572 traceDFuns :: [ClsInst] -> TcRn ()
573 traceDFuns ispecs
574 = traceTc "Adding instances:" (vcat (map pp ispecs))
575 where
576 pp ispec = hang (ppr (instanceDFunId ispec) <+> colon)
577 2 (ppr ispec)
578 -- Print the dfun name itself too
579
580 funDepErr :: ClsInst -> [ClsInst] -> TcRn ()
581 funDepErr ispec ispecs
582 = addClsInstsErr (ptext (sLit "Functional dependencies conflict between instance declarations:"))
583 (ispec : ispecs)
584
585 dupInstErr :: ClsInst -> ClsInst -> TcRn ()
586 dupInstErr ispec dup_ispec
587 = addClsInstsErr (ptext (sLit "Duplicate instance declarations:"))
588 [ispec, dup_ispec]
589
590 addClsInstsErr :: SDoc -> [ClsInst] -> TcRn ()
591 addClsInstsErr herald ispecs
592 = setSrcSpan (getSrcSpan (head sorted)) $
593 addErr (hang herald 2 (pprInstances sorted))
594 where
595 sorted = sortWith getSrcLoc ispecs
596 -- The sortWith just arranges that instances are dislayed in order
597 -- of source location, which reduced wobbling in error messages,
598 -- and is better for users
599
600 {-
601 ************************************************************************
602 * *
603 Simple functions over evidence variables
604 * *
605 ************************************************************************
606 -}
607
608 ---------------- Getting free tyvars -------------------------
609 tyVarsOfCt :: Ct -> TcTyVarSet
610 tyVarsOfCt (CTyEqCan { cc_tyvar = tv, cc_rhs = xi }) = extendVarSet (tyVarsOfType xi) tv
611 tyVarsOfCt (CFunEqCan { cc_tyargs = tys, cc_fsk = fsk }) = extendVarSet (tyVarsOfTypes tys) fsk
612 tyVarsOfCt (CDictCan { cc_tyargs = tys }) = tyVarsOfTypes tys
613 tyVarsOfCt (CIrredEvCan { cc_ev = ev }) = tyVarsOfType (ctEvPred ev)
614 tyVarsOfCt (CHoleCan { cc_ev = ev }) = tyVarsOfType (ctEvPred ev)
615 tyVarsOfCt (CNonCanonical { cc_ev = ev }) = tyVarsOfType (ctEvPred ev)
616
617 tyVarsOfCts :: Cts -> TcTyVarSet
618 tyVarsOfCts = foldrBag (unionVarSet . tyVarsOfCt) emptyVarSet
619
620 tyVarsOfWC :: WantedConstraints -> TyVarSet
621 -- Only called on *zonked* things, hence no need to worry about flatten-skolems
622 tyVarsOfWC (WC { wc_simple = simple, wc_impl = implic, wc_insol = insol })
623 = tyVarsOfCts simple `unionVarSet`
624 tyVarsOfBag tyVarsOfImplic implic `unionVarSet`
625 tyVarsOfCts insol
626
627 tyVarsOfImplic :: Implication -> TyVarSet
628 -- Only called on *zonked* things, hence no need to worry about flatten-skolems
629 tyVarsOfImplic (Implic { ic_skols = skols
630 , ic_given = givens, ic_wanted = wanted })
631 = (tyVarsOfWC wanted `unionVarSet` tyVarsOfTypes (map evVarPred givens))
632 `delVarSetList` skols
633
634 tyVarsOfBag :: (a -> TyVarSet) -> Bag a -> TyVarSet
635 tyVarsOfBag tvs_of = foldrBag (unionVarSet . tvs_of) emptyVarSet