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