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