Rename getCtLoc, setCtLoc
[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 modified_orig pred
236 ; return (EvId ev_var) }
237 where
238 -- Coercible constraints appear as normal class constraints, but
239 -- are aggressively canonicalized and manipulated during solving.
240 -- The final equality to solve may barely resemble the initial
241 -- constraint. Here, we remember the initial constraint in a
242 -- CtOrigin for better error messages. It's perhaps worthwhile
243 -- considering making this approach general, for other class
244 -- constraints, too.
245 modified_orig
246 | Just (Representational, ty1, ty2) <- getEqPredTys_maybe pred
247 = CoercibleOrigin ty1 ty2
248 | otherwise
249 = orig
250
251 instDFunType :: DFunId -> [DFunInstType] -> TcM ([TcType], TcThetaType)
252 -- See Note [DFunInstType: instantiating types] in InstEnv
253 instDFunType dfun_id dfun_inst_tys
254 = do { (subst, inst_tys) <- go (mkTopTvSubst []) dfun_tvs dfun_inst_tys
255 ; return (inst_tys, substTheta subst dfun_theta) }
256 where
257 (dfun_tvs, dfun_theta, _) = tcSplitSigmaTy (idType dfun_id)
258
259 go :: TvSubst -> [TyVar] -> [DFunInstType] -> TcM (TvSubst, [TcType])
260 go subst [] [] = return (subst, [])
261 go subst (tv:tvs) (Just ty : mb_tys)
262 = do { (subst', tys) <- go (extendTvSubst subst tv ty) tvs mb_tys
263 ; return (subst', ty : tys) }
264 go subst (tv:tvs) (Nothing : mb_tys)
265 = do { (subst', tv') <- tcInstTyVarX subst tv
266 ; (subst'', tys) <- go subst' tvs mb_tys
267 ; return (subst'', mkTyVarTy tv' : tys) }
268 go _ _ _ = pprPanic "instDFunTypes" (ppr dfun_id $$ ppr dfun_inst_tys)
269
270 ----------------
271 instStupidTheta :: CtOrigin -> TcThetaType -> TcM ()
272 -- Similar to instCall, but only emit the constraints in the LIE
273 -- Used exclusively for the 'stupid theta' of a data constructor
274 instStupidTheta orig theta
275 = do { _co <- instCallConstraints orig theta -- Discard the coercion
276 ; return () }
277
278 {-
279 ************************************************************************
280 * *
281 Literals
282 * *
283 ************************************************************************
284
285 In newOverloadedLit we convert directly to an Int or Integer if we
286 know that's what we want. This may save some time, by not
287 temporarily generating overloaded literals, but it won't catch all
288 cases (the rest are caught in lookupInst).
289 -}
290
291 newOverloadedLit :: CtOrigin
292 -> HsOverLit Name
293 -> TcRhoType
294 -> TcM (HsOverLit TcId)
295 newOverloadedLit orig lit res_ty
296 = do dflags <- getDynFlags
297 newOverloadedLit' dflags orig lit res_ty
298
299 newOverloadedLit' :: DynFlags
300 -> CtOrigin
301 -> HsOverLit Name
302 -> TcRhoType
303 -> TcM (HsOverLit TcId)
304 newOverloadedLit' dflags orig
305 lit@(OverLit { ol_val = val, ol_rebindable = rebindable
306 , ol_witness = meth_name }) res_ty
307
308 | not rebindable
309 , Just expr <- shortCutLit dflags val res_ty
310 -- Do not generate a LitInst for rebindable syntax.
311 -- Reason: If we do, tcSimplify will call lookupInst, which
312 -- will call tcSyntaxName, which does unification,
313 -- which tcSimplify doesn't like
314 = return (lit { ol_witness = expr, ol_type = res_ty
315 , ol_rebindable = rebindable })
316
317 | otherwise
318 = do { hs_lit <- mkOverLit val
319 ; let lit_ty = hsLitType hs_lit
320 ; fi' <- tcSyntaxOp orig meth_name (mkFunTy lit_ty res_ty)
321 -- Overloaded literals must have liftedTypeKind, because
322 -- we're instantiating an overloaded function here,
323 -- whereas res_ty might be openTypeKind. This was a bug in 6.2.2
324 -- However this'll be picked up by tcSyntaxOp if necessary
325 ; let witness = HsApp (noLoc fi') (noLoc (HsLit hs_lit))
326 ; return (lit { ol_witness = witness, ol_type = res_ty
327 , ol_rebindable = rebindable }) }
328
329 ------------
330 mkOverLit :: OverLitVal -> TcM HsLit
331 mkOverLit (HsIntegral src i)
332 = do { integer_ty <- tcMetaTy integerTyConName
333 ; return (HsInteger src i integer_ty) }
334
335 mkOverLit (HsFractional r)
336 = do { rat_ty <- tcMetaTy rationalTyConName
337 ; return (HsRat r rat_ty) }
338
339 mkOverLit (HsIsString src s) = return (HsString src s)
340
341 {-
342 ************************************************************************
343 * *
344 Re-mappable syntax
345
346 Used only for arrow syntax -- find a way to nuke this
347 * *
348 ************************************************************************
349
350 Suppose we are doing the -XRebindableSyntax thing, and we encounter
351 a do-expression. We have to find (>>) in the current environment, which is
352 done by the rename. Then we have to check that it has the same type as
353 Control.Monad.(>>). Or, more precisely, a compatible type. One 'customer' had
354 this:
355
356 (>>) :: HB m n mn => m a -> n b -> mn b
357
358 So the idea is to generate a local binding for (>>), thus:
359
360 let then72 :: forall a b. m a -> m b -> m b
361 then72 = ...something involving the user's (>>)...
362 in
363 ...the do-expression...
364
365 Now the do-expression can proceed using then72, which has exactly
366 the expected type.
367
368 In fact tcSyntaxName just generates the RHS for then72, because we only
369 want an actual binding in the do-expression case. For literals, we can
370 just use the expression inline.
371 -}
372
373 tcSyntaxName :: CtOrigin
374 -> TcType -- Type to instantiate it at
375 -> (Name, HsExpr Name) -- (Standard name, user name)
376 -> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression)
377 -- USED ONLY FOR CmdTop (sigh) ***
378 -- See Note [CmdSyntaxTable] in HsExpr
379
380 tcSyntaxName orig ty (std_nm, HsVar user_nm)
381 | std_nm == user_nm
382 = do rhs <- newMethodFromName orig std_nm ty
383 return (std_nm, rhs)
384
385 tcSyntaxName orig ty (std_nm, user_nm_expr) = do
386 std_id <- tcLookupId std_nm
387 let
388 -- C.f. newMethodAtLoc
389 ([tv], _, tau) = tcSplitSigmaTy (idType std_id)
390 sigma1 = substTyWith [tv] [ty] tau
391 -- Actually, the "tau-type" might be a sigma-type in the
392 -- case of locally-polymorphic methods.
393
394 addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $ do
395
396 -- Check that the user-supplied thing has the
397 -- same type as the standard one.
398 -- Tiresome jiggling because tcCheckSigma takes a located expression
399 span <- getSrcSpanM
400 expr <- tcPolyExpr (L span user_nm_expr) sigma1
401 return (std_nm, unLoc expr)
402
403 syntaxNameCtxt :: HsExpr Name -> CtOrigin -> Type -> TidyEnv
404 -> TcRn (TidyEnv, SDoc)
405 syntaxNameCtxt name orig ty tidy_env
406 = do { inst_loc <- getCtLocM orig
407 ; let msg = vcat [ ptext (sLit "When checking that") <+> quotes (ppr name)
408 <+> ptext (sLit "(needed by a syntactic construct)")
409 , nest 2 (ptext (sLit "has the required type:")
410 <+> ppr (tidyType tidy_env ty))
411 , nest 2 (pprArisingAt inst_loc) ]
412 ; return (tidy_env, msg) }
413
414 {-
415 ************************************************************************
416 * *
417 Instances
418 * *
419 ************************************************************************
420 -}
421
422 getOverlapFlag :: Maybe OverlapMode -> TcM OverlapFlag
423 getOverlapFlag overlap_mode
424 = do { dflags <- getDynFlags
425 ; let overlap_ok = xopt Opt_OverlappingInstances dflags
426 incoherent_ok = xopt Opt_IncoherentInstances dflags
427 use x = OverlapFlag { isSafeOverlap = safeLanguageOn dflags
428 , overlapMode = x }
429 default_oflag | incoherent_ok = use (Incoherent "")
430 | overlap_ok = use (Overlaps "")
431 | otherwise = use (NoOverlap "")
432
433 final_oflag = setOverlapModeMaybe default_oflag overlap_mode
434 ; return final_oflag }
435
436 tcGetInsts :: TcM [ClsInst]
437 -- Gets the local class instances.
438 tcGetInsts = fmap tcg_insts getGblEnv
439
440 newClsInst :: Maybe OverlapMode -> Name -> [TyVar] -> ThetaType
441 -> Class -> [Type] -> TcM ClsInst
442 newClsInst overlap_mode dfun_name tvs theta clas tys
443 = do { (subst, tvs') <- freshenTyVarBndrs tvs
444 -- Be sure to freshen those type variables,
445 -- so they are sure not to appear in any lookup
446 ; let tys' = substTys subst tys
447 theta' = substTheta subst theta
448 dfun = mkDictFunId dfun_name tvs' theta' clas tys'
449 -- Substituting in the DFun type just makes sure that
450 -- we are using TyVars rather than TcTyVars
451 -- Not sure if this is really the right place to do so,
452 -- but it'll do fine
453 ; oflag <- getOverlapFlag overlap_mode
454 ; return (mkLocalInstance dfun oflag tvs' clas tys') }
455
456 tcExtendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a
457 -- Add new locally-defined instances
458 tcExtendLocalInstEnv dfuns thing_inside
459 = do { traceDFuns dfuns
460 ; env <- getGblEnv
461 ; (inst_env', cls_insts') <- foldlM addLocalInst
462 (tcg_inst_env env, tcg_insts env)
463 dfuns
464 ; let env' = env { tcg_insts = cls_insts'
465 , tcg_inst_env = inst_env' }
466 ; setGblEnv env' thing_inside }
467
468 addLocalInst :: (InstEnv, [ClsInst]) -> ClsInst -> TcM (InstEnv, [ClsInst])
469 -- Check that the proposed new instance is OK,
470 -- and then add it to the home inst env
471 -- If overwrite_inst, then we can overwrite a direct match
472 addLocalInst (home_ie, my_insts) ispec
473 = do {
474 -- Instantiate the dfun type so that we extend the instance
475 -- envt with completely fresh template variables
476 -- This is important because the template variables must
477 -- not overlap with anything in the things being looked up
478 -- (since we do unification).
479 --
480 -- We use tcInstSkolType because we don't want to allocate fresh
481 -- *meta* type variables.
482 --
483 -- We use UnkSkol --- and *not* InstSkol or PatSkol --- because
484 -- these variables must be bindable by tcUnifyTys. See
485 -- the call to tcUnifyTys in InstEnv, and the special
486 -- treatment that instanceBindFun gives to isOverlappableTyVar
487 -- This is absurdly delicate.
488
489 -- Load imported instances, so that we report
490 -- duplicates correctly
491
492 -- 'matches' are existing instance declarations that are less
493 -- specific than the new one
494 -- 'dups' are those 'matches' that are equal to the new one
495 ; isGHCi <- getIsGHCi
496 ; eps <- getEps
497 ; tcg_env <- getGblEnv
498
499 -- In GHCi, we *override* any identical instances
500 -- that are also defined in the interactive context
501 -- See Note [Override identical instances in GHCi]
502 ; let home_ie'
503 | isGHCi = deleteFromInstEnv home_ie ispec
504 | otherwise = home_ie
505
506 (_tvs, cls, tys) = instanceHead ispec
507 -- If we're compiling sig-of and there's an external duplicate
508 -- instance, silently ignore it (that's the instance we're
509 -- implementing!) NB: we still count local duplicate instances
510 -- as errors.
511 -- See Note [Signature files and type class instances]
512 global_ie
513 | isJust (tcg_sig_of tcg_env) = emptyInstEnv
514 | otherwise = eps_inst_env eps
515 inst_envs = InstEnvs { ie_global = global_ie
516 , ie_local = home_ie'
517 , ie_visible = tcVisibleOrphanMods tcg_env }
518 (matches, _, _) = lookupInstEnv False inst_envs cls tys
519 dups = filter (identicalClsInstHead ispec) (map fst matches)
520
521 -- Check functional dependencies
522 ; case checkFunDeps inst_envs ispec of
523 Just specs -> funDepErr ispec specs
524 Nothing -> return ()
525
526 -- Check for duplicate instance decls.
527 ; unless (null dups) $
528 dupInstErr ispec (head dups)
529
530 ; return (extendInstEnv home_ie' ispec, ispec : my_insts) }
531
532 {-
533 Note [Signature files and type class instances]
534 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
535 Instances in signature files do not have an effect when compiling:
536 when you compile a signature against an implementation, you will
537 see the instances WHETHER OR NOT the instance is declared in
538 the file (this is because the signatures go in the EPS and we
539 can't filter them out easily.) This is also why we cannot
540 place the instance in the hi file: it would show up as a duplicate,
541 and we don't have instance reexports anyway.
542
543 However, you might find them useful when typechecking against
544 a signature: the instance is a way of indicating to GHC that
545 some instance exists, in case downstream code uses it.
546
547 Implementing this is a little tricky. Consider the following
548 situation (sigof03):
549
550 module A where
551 instance C T where ...
552
553 module ASig where
554 instance C T
555
556 When compiling ASig, A.hi is loaded, which brings its instances
557 into the EPS. When we process the instance declaration in ASig,
558 we should ignore it for the purpose of doing a duplicate check,
559 since it's not actually a duplicate. But don't skip the check
560 entirely, we still want this to fail (tcfail221):
561
562 module ASig where
563 instance C T
564 instance C T
565
566 Note that in some situations, the interface containing the type
567 class instances may not have been loaded yet at all. The usual
568 situation when A imports another module which provides the
569 instances (sigof02m):
570
571 module A(module B) where
572 import B
573
574 See also Note [Signature lazy interface loading]. We can't
575 rely on this, however, since sometimes we'll have spurious
576 type class instances in the EPS, see #9422 (sigof02dm)
577
578 ************************************************************************
579 * *
580 Errors and tracing
581 * *
582 ************************************************************************
583 -}
584
585 traceDFuns :: [ClsInst] -> TcRn ()
586 traceDFuns ispecs
587 = traceTc "Adding instances:" (vcat (map pp ispecs))
588 where
589 pp ispec = hang (ppr (instanceDFunId ispec) <+> colon)
590 2 (ppr ispec)
591 -- Print the dfun name itself too
592
593 funDepErr :: ClsInst -> [ClsInst] -> TcRn ()
594 funDepErr ispec ispecs
595 = addClsInstsErr (ptext (sLit "Functional dependencies conflict between instance declarations:"))
596 (ispec : ispecs)
597
598 dupInstErr :: ClsInst -> ClsInst -> TcRn ()
599 dupInstErr ispec dup_ispec
600 = addClsInstsErr (ptext (sLit "Duplicate instance declarations:"))
601 [ispec, dup_ispec]
602
603 addClsInstsErr :: SDoc -> [ClsInst] -> TcRn ()
604 addClsInstsErr herald ispecs
605 = setSrcSpan (getSrcSpan (head sorted)) $
606 addErr (hang herald 2 (pprInstances sorted))
607 where
608 sorted = sortWith getSrcLoc ispecs
609 -- The sortWith just arranges that instances are dislayed in order
610 -- of source location, which reduced wobbling in error messages,
611 -- and is better for users
612
613 {-
614 ************************************************************************
615 * *
616 Simple functions over evidence variables
617 * *
618 ************************************************************************
619 -}
620
621 ---------------- Getting free tyvars -------------------------
622 tyVarsOfCt :: Ct -> TcTyVarSet
623 tyVarsOfCt (CTyEqCan { cc_tyvar = tv, cc_rhs = xi }) = extendVarSet (tyVarsOfType xi) tv
624 tyVarsOfCt (CFunEqCan { cc_tyargs = tys, cc_fsk = fsk }) = extendVarSet (tyVarsOfTypes tys) fsk
625 tyVarsOfCt (CDictCan { cc_tyargs = tys }) = tyVarsOfTypes tys
626 tyVarsOfCt (CIrredEvCan { cc_ev = ev }) = tyVarsOfType (ctEvPred ev)
627 tyVarsOfCt (CHoleCan { cc_ev = ev }) = tyVarsOfType (ctEvPred ev)
628 tyVarsOfCt (CNonCanonical { cc_ev = ev }) = tyVarsOfType (ctEvPred ev)
629
630 tyVarsOfCts :: Cts -> TcTyVarSet
631 tyVarsOfCts = foldrBag (unionVarSet . tyVarsOfCt) emptyVarSet
632
633 tyVarsOfWC :: WantedConstraints -> TyVarSet
634 -- Only called on *zonked* things, hence no need to worry about flatten-skolems
635 tyVarsOfWC (WC { wc_simple = simple, wc_impl = implic, wc_insol = insol })
636 = tyVarsOfCts simple `unionVarSet`
637 tyVarsOfBag tyVarsOfImplic implic `unionVarSet`
638 tyVarsOfCts insol
639
640 tyVarsOfImplic :: Implication -> TyVarSet
641 -- Only called on *zonked* things, hence no need to worry about flatten-skolems
642 tyVarsOfImplic (Implic { ic_skols = skols
643 , ic_given = givens, ic_wanted = wanted })
644 = (tyVarsOfWC wanted `unionVarSet` tyVarsOfTypes (map evVarPred givens))
645 `delVarSetList` skols
646
647 tyVarsOfBag :: (a -> TyVarSet) -> Bag a -> TyVarSet
648 tyVarsOfBag tvs_of = foldrBag (unionVarSet . tvs_of) emptyVarSet