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