Move orphan instance/rule warnings to typechecker/desugarer.
[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 -- Construct the OverlapFlag from the global module flags,
411 -- but if the overlap_mode argument is (Just m),
412 -- set the OverlapMode to 'm'
413 getOverlapFlag overlap_mode
414 = do { dflags <- getDynFlags
415 ; let overlap_ok = xopt Opt_OverlappingInstances dflags
416 incoherent_ok = xopt Opt_IncoherentInstances dflags
417 use x = OverlapFlag { isSafeOverlap = safeLanguageOn dflags
418 , overlapMode = x }
419 default_oflag | incoherent_ok = use (Incoherent "")
420 | overlap_ok = use (Overlaps "")
421 | otherwise = use (NoOverlap "")
422
423 final_oflag = setOverlapModeMaybe default_oflag overlap_mode
424 ; return final_oflag }
425
426 tcGetInsts :: TcM [ClsInst]
427 -- Gets the local class instances.
428 tcGetInsts = fmap tcg_insts getGblEnv
429
430 newClsInst :: Maybe OverlapMode -> Name -> [TyVar] -> ThetaType
431 -> Class -> [Type] -> TcM ClsInst
432 newClsInst overlap_mode dfun_name tvs theta clas tys
433 = do { (subst, tvs') <- freshenTyVarBndrs tvs
434 -- Be sure to freshen those type variables,
435 -- so they are sure not to appear in any lookup
436 ; let tys' = substTys subst tys
437 theta' = substTheta subst theta
438 dfun = mkDictFunId dfun_name tvs' theta' clas tys'
439 -- Substituting in the DFun type just makes sure that
440 -- we are using TyVars rather than TcTyVars
441 -- Not sure if this is really the right place to do so,
442 -- but it'll do fine
443 ; oflag <- getOverlapFlag overlap_mode
444 ; let inst = mkLocalInstance dfun oflag tvs' clas tys'
445 ; dflags <- getDynFlags
446 ; warnIf (isOrphan (is_orphan inst) && wopt Opt_WarnOrphans dflags) (instOrphWarn inst)
447 ; return inst }
448
449 instOrphWarn :: ClsInst -> SDoc
450 instOrphWarn inst
451 = hang (ptext (sLit "Orphan instance:")) 2 (pprInstanceHdr inst)
452 $$ text "To avoid this"
453 $$ nest 4 (vcat possibilities)
454 where
455 possibilities =
456 text "move the instance declaration to the module of the class or of the type, or" :
457 text "wrap the type with a newtype and declare the instance on the new type." :
458 []
459
460 tcExtendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a
461 -- Add new locally-defined instances
462 tcExtendLocalInstEnv dfuns thing_inside
463 = do { traceDFuns dfuns
464 ; env <- getGblEnv
465 ; (inst_env', cls_insts') <- foldlM addLocalInst
466 (tcg_inst_env env, tcg_insts env)
467 dfuns
468 ; let env' = env { tcg_insts = cls_insts'
469 , tcg_inst_env = inst_env' }
470 ; setGblEnv env' thing_inside }
471
472 addLocalInst :: (InstEnv, [ClsInst]) -> ClsInst -> TcM (InstEnv, [ClsInst])
473 -- Check that the proposed new instance is OK,
474 -- and then add it to the home inst env
475 -- If overwrite_inst, then we can overwrite a direct match
476 addLocalInst (home_ie, my_insts) ispec
477 = do {
478 -- Instantiate the dfun type so that we extend the instance
479 -- envt with completely fresh template variables
480 -- This is important because the template variables must
481 -- not overlap with anything in the things being looked up
482 -- (since we do unification).
483 --
484 -- We use tcInstSkolType because we don't want to allocate fresh
485 -- *meta* type variables.
486 --
487 -- We use UnkSkol --- and *not* InstSkol or PatSkol --- because
488 -- these variables must be bindable by tcUnifyTys. See
489 -- the call to tcUnifyTys in InstEnv, and the special
490 -- treatment that instanceBindFun gives to isOverlappableTyVar
491 -- This is absurdly delicate.
492
493 -- Load imported instances, so that we report
494 -- duplicates correctly
495
496 -- 'matches' are existing instance declarations that are less
497 -- specific than the new one
498 -- 'dups' are those 'matches' that are equal to the new one
499 ; isGHCi <- getIsGHCi
500 ; eps <- getEps
501 ; tcg_env <- getGblEnv
502
503 -- In GHCi, we *override* any identical instances
504 -- that are also defined in the interactive context
505 -- See Note [Override identical instances in GHCi]
506 ; let home_ie'
507 | isGHCi = deleteFromInstEnv home_ie ispec
508 | otherwise = home_ie
509
510 -- If we're compiling sig-of and there's an external duplicate
511 -- instance, silently ignore it (that's the instance we're
512 -- implementing!) NB: we still count local duplicate instances
513 -- as errors.
514 -- See Note [Signature files and type class instances]
515 global_ie | isJust (tcg_sig_of tcg_env) = emptyInstEnv
516 | otherwise = eps_inst_env eps
517 inst_envs = InstEnvs { ie_global = global_ie
518 , ie_local = home_ie'
519 , ie_visible = tcVisibleOrphanMods tcg_env }
520
521 -- Check for inconsistent functional dependencies
522 ; let inconsistent_ispecs = checkFunDeps inst_envs ispec
523 ; unless (null inconsistent_ispecs) $
524 funDepErr ispec inconsistent_ispecs
525
526 -- Check for duplicate instance decls.
527 ; let (_tvs, cls, tys) = instanceHead ispec
528 (matches, _, _) = lookupInstEnv False inst_envs cls tys
529 dups = filter (identicalClsInstHead ispec) (map fst matches)
530 ; unless (null dups) $
531 dupInstErr ispec (head dups)
532
533 ; return (extendInstEnv home_ie' ispec, ispec : my_insts) }
534
535 {-
536 Note [Signature files and type class instances]
537 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
538 Instances in signature files do not have an effect when compiling:
539 when you compile a signature against an implementation, you will
540 see the instances WHETHER OR NOT the instance is declared in
541 the file (this is because the signatures go in the EPS and we
542 can't filter them out easily.) This is also why we cannot
543 place the instance in the hi file: it would show up as a duplicate,
544 and we don't have instance reexports anyway.
545
546 However, you might find them useful when typechecking against
547 a signature: the instance is a way of indicating to GHC that
548 some instance exists, in case downstream code uses it.
549
550 Implementing this is a little tricky. Consider the following
551 situation (sigof03):
552
553 module A where
554 instance C T where ...
555
556 module ASig where
557 instance C T
558
559 When compiling ASig, A.hi is loaded, which brings its instances
560 into the EPS. When we process the instance declaration in ASig,
561 we should ignore it for the purpose of doing a duplicate check,
562 since it's not actually a duplicate. But don't skip the check
563 entirely, we still want this to fail (tcfail221):
564
565 module ASig where
566 instance C T
567 instance C T
568
569 Note that in some situations, the interface containing the type
570 class instances may not have been loaded yet at all. The usual
571 situation when A imports another module which provides the
572 instances (sigof02m):
573
574 module A(module B) where
575 import B
576
577 See also Note [Signature lazy interface loading]. We can't
578 rely on this, however, since sometimes we'll have spurious
579 type class instances in the EPS, see #9422 (sigof02dm)
580
581 ************************************************************************
582 * *
583 Errors and tracing
584 * *
585 ************************************************************************
586 -}
587
588 traceDFuns :: [ClsInst] -> TcRn ()
589 traceDFuns ispecs
590 = traceTc "Adding instances:" (vcat (map pp ispecs))
591 where
592 pp ispec = hang (ppr (instanceDFunId ispec) <+> colon)
593 2 (ppr ispec)
594 -- Print the dfun name itself too
595
596 funDepErr :: ClsInst -> [ClsInst] -> TcRn ()
597 funDepErr ispec ispecs
598 = addClsInstsErr (ptext (sLit "Functional dependencies conflict between instance declarations:"))
599 (ispec : ispecs)
600
601 dupInstErr :: ClsInst -> ClsInst -> TcRn ()
602 dupInstErr ispec dup_ispec
603 = addClsInstsErr (ptext (sLit "Duplicate instance declarations:"))
604 [ispec, dup_ispec]
605
606 addClsInstsErr :: SDoc -> [ClsInst] -> TcRn ()
607 addClsInstsErr herald ispecs
608 = setSrcSpan (getSrcSpan (head sorted)) $
609 addErr (hang herald 2 (pprInstances sorted))
610 where
611 sorted = sortWith getSrcLoc ispecs
612 -- The sortWith just arranges that instances are dislayed in order
613 -- of source location, which reduced wobbling in error messages,
614 -- and is better for users
615
616 {-
617 ************************************************************************
618 * *
619 Simple functions over evidence variables
620 * *
621 ************************************************************************
622 -}
623
624 ---------------- Getting free tyvars -------------------------
625 tyVarsOfCt :: Ct -> TcTyVarSet
626 tyVarsOfCt (CTyEqCan { cc_tyvar = tv, cc_rhs = xi }) = extendVarSet (tyVarsOfType xi) tv
627 tyVarsOfCt (CFunEqCan { cc_tyargs = tys, cc_fsk = fsk }) = extendVarSet (tyVarsOfTypes tys) fsk
628 tyVarsOfCt (CDictCan { cc_tyargs = tys }) = tyVarsOfTypes tys
629 tyVarsOfCt (CIrredEvCan { cc_ev = ev }) = tyVarsOfType (ctEvPred ev)
630 tyVarsOfCt (CHoleCan { cc_ev = ev }) = tyVarsOfType (ctEvPred ev)
631 tyVarsOfCt (CNonCanonical { cc_ev = ev }) = tyVarsOfType (ctEvPred ev)
632
633 tyVarsOfCts :: Cts -> TcTyVarSet
634 tyVarsOfCts = foldrBag (unionVarSet . tyVarsOfCt) emptyVarSet
635
636 tyVarsOfWC :: WantedConstraints -> TyVarSet
637 -- Only called on *zonked* things, hence no need to worry about flatten-skolems
638 tyVarsOfWC (WC { wc_simple = simple, wc_impl = implic, wc_insol = insol })
639 = tyVarsOfCts simple `unionVarSet`
640 tyVarsOfBag tyVarsOfImplic implic `unionVarSet`
641 tyVarsOfCts insol
642
643 tyVarsOfImplic :: Implication -> TyVarSet
644 -- Only called on *zonked* things, hence no need to worry about flatten-skolems
645 tyVarsOfImplic (Implic { ic_skols = skols
646 , ic_given = givens, ic_wanted = wanted })
647 = (tyVarsOfWC wanted `unionVarSet` tyVarsOfTypes (map evVarPred givens))
648 `delVarSetList` skols
649
650 tyVarsOfBag :: (a -> TyVarSet) -> Bag a -> TyVarSet
651 tyVarsOfBag tvs_of = foldrBag (unionVarSet . tvs_of) emptyVarSet