Refactor overloaded literals back to Inst
[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, TupleSections #-}
10
11 module Inst (
12 deeplySkolemise,
13 topInstantiate, topInstantiateInferred, deeplyInstantiate,
14 instCall, instDFunType, instStupidTheta,
15 newWanted, newWanteds,
16 emitWanted, emitWanteds,
17
18 newOverloadedLit, 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 {-
335 In newOverloadedLit we convert directly to an Int or Integer if we
336 know that's what we want. This may save some time, by not
337 temporarily generating overloaded literals, but it won't catch all
338 cases (the rest are caught in lookupInst).
339
340 -}
341
342 newOverloadedLit :: HsOverLit Name
343 -> TcSigmaType -- if nec'y, this type is instantiated...
344 -> CtOrigin -- ... using this CtOrigin
345 -> TcM (HsWrapper, HsOverLit TcId)
346 -- wrapper :: input type "->" type of result
347 newOverloadedLit
348 lit@(OverLit { ol_val = val, ol_rebindable = rebindable }) res_ty res_orig
349 | not rebindable
350 -- all built-in overloaded lits are not higher-rank, so skolemise.
351 -- this is necessary for shortCutLit.
352 = do { (wrap, insted_ty) <- deeplyInstantiate res_orig res_ty
353 ; dflags <- getDynFlags
354 ; case shortCutLit dflags val insted_ty of
355 -- Do not generate a LitInst for rebindable syntax.
356 -- Reason: If we do, tcSimplify will call lookupInst, which
357 -- will call tcSyntaxName, which does unification,
358 -- which tcSimplify doesn't like
359 Just expr -> return ( wrap
360 , lit { ol_witness = expr, ol_type = insted_ty
361 , ol_rebindable = False } )
362 Nothing -> (wrap, ) <$>
363 newNonTrivialOverloadedLit orig lit insted_ty }
364
365 | otherwise
366 = do { lit' <- newNonTrivialOverloadedLit orig lit res_ty
367 ; return (idHsWrapper, lit') }
368 where
369 orig = LiteralOrigin lit
370
371 -- Does not handle things that 'shortCutLit' can handle. See also
372 -- newOverloadedLit in TcUnify
373 newNonTrivialOverloadedLit :: CtOrigin
374 -> HsOverLit Name
375 -> TcSigmaType
376 -> TcM (HsOverLit TcId)
377 newNonTrivialOverloadedLit orig
378 lit@(OverLit { ol_val = val, ol_witness = meth_name
379 , ol_rebindable = rebindable }) res_ty
380 = do { hs_lit <- mkOverLit val
381 ; let lit_ty = hsLitType hs_lit
382 ; fi' <- tcSyntaxOp orig meth_name (mkFunTy lit_ty res_ty)
383 -- Overloaded literals must have liftedTypeKind, because
384 -- we're instantiating an overloaded function here,
385 -- whereas res_ty might be openTypeKind. This was a bug in 6.2.2
386 -- However this'll be picked up by tcSyntaxOp if necessary
387 ; let witness = HsApp (noLoc fi') (noLoc (HsLit hs_lit))
388 ; return (lit { ol_witness = witness, ol_type = res_ty,
389 ol_rebindable = rebindable }) }
390
391 ------------
392 mkOverLit :: OverLitVal -> TcM HsLit
393 mkOverLit (HsIntegral src i)
394 = do { integer_ty <- tcMetaTy integerTyConName
395 ; return (HsInteger src i integer_ty) }
396
397 mkOverLit (HsFractional r)
398 = do { rat_ty <- tcMetaTy rationalTyConName
399 ; return (HsRat r rat_ty) }
400
401 mkOverLit (HsIsString src s) = return (HsString src s)
402
403 {-
404 ************************************************************************
405 * *
406 Re-mappable syntax
407
408 Used only for arrow syntax -- find a way to nuke this
409 * *
410 ************************************************************************
411
412 Suppose we are doing the -XRebindableSyntax thing, and we encounter
413 a do-expression. We have to find (>>) in the current environment, which is
414 done by the rename. Then we have to check that it has the same type as
415 Control.Monad.(>>). Or, more precisely, a compatible type. One 'customer' had
416 this:
417
418 (>>) :: HB m n mn => m a -> n b -> mn b
419
420 So the idea is to generate a local binding for (>>), thus:
421
422 let then72 :: forall a b. m a -> m b -> m b
423 then72 = ...something involving the user's (>>)...
424 in
425 ...the do-expression...
426
427 Now the do-expression can proceed using then72, which has exactly
428 the expected type.
429
430 In fact tcSyntaxName just generates the RHS for then72, because we only
431 want an actual binding in the do-expression case. For literals, we can
432 just use the expression inline.
433 -}
434
435 tcSyntaxName :: CtOrigin
436 -> TcType -- Type to instantiate it at
437 -> (Name, HsExpr Name) -- (Standard name, user name)
438 -> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression)
439 -- USED ONLY FOR CmdTop (sigh) ***
440 -- See Note [CmdSyntaxTable] in HsExpr
441
442 tcSyntaxName orig ty (std_nm, HsVar user_nm)
443 | std_nm == user_nm
444 = do rhs <- newMethodFromName orig std_nm ty
445 return (std_nm, rhs)
446
447 tcSyntaxName orig ty (std_nm, user_nm_expr) = do
448 std_id <- tcLookupId std_nm
449 let
450 -- C.f. newMethodAtLoc
451 ([tv], _, tau) = tcSplitSigmaTy (idType std_id)
452 sigma1 = substTyWith [tv] [ty] tau
453 -- Actually, the "tau-type" might be a sigma-type in the
454 -- case of locally-polymorphic methods.
455
456 addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $ do
457
458 -- Check that the user-supplied thing has the
459 -- same type as the standard one.
460 -- Tiresome jiggling because tcCheckSigma takes a located expression
461 span <- getSrcSpanM
462 expr <- tcPolyExpr (L span user_nm_expr) sigma1
463 return (std_nm, unLoc expr)
464
465 syntaxNameCtxt :: HsExpr Name -> CtOrigin -> Type -> TidyEnv
466 -> TcRn (TidyEnv, SDoc)
467 syntaxNameCtxt name orig ty tidy_env
468 = do { inst_loc <- getCtLocM orig
469 ; let msg = vcat [ ptext (sLit "When checking that") <+> quotes (ppr name)
470 <+> ptext (sLit "(needed by a syntactic construct)")
471 , nest 2 (ptext (sLit "has the required type:")
472 <+> ppr (tidyType tidy_env ty))
473 , nest 2 (pprCtLoc inst_loc) ]
474 ; return (tidy_env, msg) }
475
476 {-
477 ************************************************************************
478 * *
479 Instances
480 * *
481 ************************************************************************
482 -}
483
484 getOverlapFlag :: Maybe OverlapMode -> TcM OverlapFlag
485 getOverlapFlag overlap_mode
486 = do { dflags <- getDynFlags
487 ; let overlap_ok = xopt Opt_OverlappingInstances dflags
488 incoherent_ok = xopt Opt_IncoherentInstances dflags
489 use x = OverlapFlag { isSafeOverlap = safeLanguageOn dflags
490 , overlapMode = x }
491 default_oflag | incoherent_ok = use (Incoherent "")
492 | overlap_ok = use (Overlaps "")
493 | otherwise = use (NoOverlap "")
494
495 final_oflag = setOverlapModeMaybe default_oflag overlap_mode
496 ; return final_oflag }
497
498 tcGetInsts :: TcM [ClsInst]
499 -- Gets the local class instances.
500 tcGetInsts = fmap tcg_insts getGblEnv
501
502 newClsInst :: Maybe OverlapMode -> Name -> [TyVar] -> ThetaType
503 -> Class -> [Type] -> TcM ClsInst
504 newClsInst overlap_mode dfun_name tvs theta clas tys
505 = do { (subst, tvs') <- freshenTyVarBndrs tvs
506 -- Be sure to freshen those type variables,
507 -- so they are sure not to appear in any lookup
508 ; let tys' = substTys subst tys
509 theta' = substTheta subst theta
510 dfun = mkDictFunId dfun_name tvs' theta' clas tys'
511 -- Substituting in the DFun type just makes sure that
512 -- we are using TyVars rather than TcTyVars
513 -- Not sure if this is really the right place to do so,
514 -- but it'll do fine
515 ; oflag <- getOverlapFlag overlap_mode
516 ; return (mkLocalInstance dfun oflag tvs' clas tys') }
517
518 tcExtendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a
519 -- Add new locally-defined instances
520 tcExtendLocalInstEnv dfuns thing_inside
521 = do { traceDFuns dfuns
522 ; env <- getGblEnv
523 ; (inst_env', cls_insts') <- foldlM addLocalInst
524 (tcg_inst_env env, tcg_insts env)
525 dfuns
526 ; let env' = env { tcg_insts = cls_insts'
527 , tcg_inst_env = inst_env' }
528 ; setGblEnv env' thing_inside }
529
530 addLocalInst :: (InstEnv, [ClsInst]) -> ClsInst -> TcM (InstEnv, [ClsInst])
531 -- Check that the proposed new instance is OK,
532 -- and then add it to the home inst env
533 -- If overwrite_inst, then we can overwrite a direct match
534 addLocalInst (home_ie, my_insts) ispec
535 = do {
536 -- Instantiate the dfun type so that we extend the instance
537 -- envt with completely fresh template variables
538 -- This is important because the template variables must
539 -- not overlap with anything in the things being looked up
540 -- (since we do unification).
541 --
542 -- We use tcInstSkolType because we don't want to allocate fresh
543 -- *meta* type variables.
544 --
545 -- We use UnkSkol --- and *not* InstSkol or PatSkol --- because
546 -- these variables must be bindable by tcUnifyTys. See
547 -- the call to tcUnifyTys in InstEnv, and the special
548 -- treatment that instanceBindFun gives to isOverlappableTyVar
549 -- This is absurdly delicate.
550
551 -- Load imported instances, so that we report
552 -- duplicates correctly
553
554 -- 'matches' are existing instance declarations that are less
555 -- specific than the new one
556 -- 'dups' are those 'matches' that are equal to the new one
557 ; isGHCi <- getIsGHCi
558 ; eps <- getEps
559 ; tcg_env <- getGblEnv
560
561 -- In GHCi, we *override* any identical instances
562 -- that are also defined in the interactive context
563 -- See Note [Override identical instances in GHCi]
564 ; let home_ie'
565 | isGHCi = deleteFromInstEnv home_ie ispec
566 | otherwise = home_ie
567
568 (_tvs, cls, tys) = instanceHead ispec
569 -- If we're compiling sig-of and there's an external duplicate
570 -- instance, silently ignore it (that's the instance we're
571 -- implementing!) NB: we still count local duplicate instances
572 -- as errors.
573 -- See Note [Signature files and type class instances]
574 global_ie
575 | isJust (tcg_sig_of tcg_env) = emptyInstEnv
576 | otherwise = eps_inst_env eps
577 inst_envs = InstEnvs { ie_global = global_ie
578 , ie_local = home_ie'
579 , ie_visible = tcVisibleOrphanMods tcg_env }
580 (matches, _, _) = lookupInstEnv False inst_envs cls tys
581 dups = filter (identicalClsInstHead ispec) (map fst matches)
582
583 -- Check functional dependencies
584 ; case checkFunDeps inst_envs ispec of
585 Just specs -> funDepErr ispec specs
586 Nothing -> return ()
587
588 -- Check for duplicate instance decls.
589 ; unless (null dups) $
590 dupInstErr ispec (head dups)
591
592 ; return (extendInstEnv home_ie' ispec, ispec : my_insts) }
593
594 {-
595 Note [Signature files and type class instances]
596 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
597 Instances in signature files do not have an effect when compiling:
598 when you compile a signature against an implementation, you will
599 see the instances WHETHER OR NOT the instance is declared in
600 the file (this is because the signatures go in the EPS and we
601 can't filter them out easily.) This is also why we cannot
602 place the instance in the hi file: it would show up as a duplicate,
603 and we don't have instance reexports anyway.
604
605 However, you might find them useful when typechecking against
606 a signature: the instance is a way of indicating to GHC that
607 some instance exists, in case downstream code uses it.
608
609 Implementing this is a little tricky. Consider the following
610 situation (sigof03):
611
612 module A where
613 instance C T where ...
614
615 module ASig where
616 instance C T
617
618 When compiling ASig, A.hi is loaded, which brings its instances
619 into the EPS. When we process the instance declaration in ASig,
620 we should ignore it for the purpose of doing a duplicate check,
621 since it's not actually a duplicate. But don't skip the check
622 entirely, we still want this to fail (tcfail221):
623
624 module ASig where
625 instance C T
626 instance C T
627
628 Note that in some situations, the interface containing the type
629 class instances may not have been loaded yet at all. The usual
630 situation when A imports another module which provides the
631 instances (sigof02m):
632
633 module A(module B) where
634 import B
635
636 See also Note [Signature lazy interface loading]. We can't
637 rely on this, however, since sometimes we'll have spurious
638 type class instances in the EPS, see #9422 (sigof02dm)
639
640 ************************************************************************
641 * *
642 Errors and tracing
643 * *
644 ************************************************************************
645 -}
646
647 traceDFuns :: [ClsInst] -> TcRn ()
648 traceDFuns ispecs
649 = traceTc "Adding instances:" (vcat (map pp ispecs))
650 where
651 pp ispec = hang (ppr (instanceDFunId ispec) <+> colon)
652 2 (ppr ispec)
653 -- Print the dfun name itself too
654
655 funDepErr :: ClsInst -> [ClsInst] -> TcRn ()
656 funDepErr ispec ispecs
657 = addClsInstsErr (ptext (sLit "Functional dependencies conflict between instance declarations:"))
658 (ispec : ispecs)
659
660 dupInstErr :: ClsInst -> ClsInst -> TcRn ()
661 dupInstErr ispec dup_ispec
662 = addClsInstsErr (ptext (sLit "Duplicate instance declarations:"))
663 [ispec, dup_ispec]
664
665 addClsInstsErr :: SDoc -> [ClsInst] -> TcRn ()
666 addClsInstsErr herald ispecs
667 = setSrcSpan (getSrcSpan (head sorted)) $
668 addErr (hang herald 2 (pprInstances sorted))
669 where
670 sorted = sortWith getSrcLoc ispecs
671 -- The sortWith just arranges that instances are dislayed in order
672 -- of source location, which reduced wobbling in error messages,
673 -- and is better for users
674
675 {-
676 ************************************************************************
677 * *
678 Simple functions over evidence variables
679 * *
680 ************************************************************************
681 -}
682
683 ---------------- Getting free tyvars -------------------------
684 tyVarsOfCt :: Ct -> TcTyVarSet
685 tyVarsOfCt (CTyEqCan { cc_tyvar = tv, cc_rhs = xi }) = extendVarSet (tyVarsOfType xi) tv
686 tyVarsOfCt (CFunEqCan { cc_tyargs = tys, cc_fsk = fsk }) = extendVarSet (tyVarsOfTypes tys) fsk
687 tyVarsOfCt (CDictCan { cc_tyargs = tys }) = tyVarsOfTypes tys
688 tyVarsOfCt (CIrredEvCan { cc_ev = ev }) = tyVarsOfType (ctEvPred ev)
689 tyVarsOfCt (CHoleCan { cc_ev = ev }) = tyVarsOfType (ctEvPred ev)
690 tyVarsOfCt (CNonCanonical { cc_ev = ev }) = tyVarsOfType (ctEvPred ev)
691
692 tyVarsOfCts :: Cts -> TcTyVarSet
693 tyVarsOfCts = foldrBag (unionVarSet . tyVarsOfCt) emptyVarSet
694
695 tyVarsOfWC :: WantedConstraints -> TyVarSet
696 -- Only called on *zonked* things, hence no need to worry about flatten-skolems
697 tyVarsOfWC (WC { wc_simple = simple, wc_impl = implic, wc_insol = insol })
698 = tyVarsOfCts simple `unionVarSet`
699 tyVarsOfBag tyVarsOfImplic implic `unionVarSet`
700 tyVarsOfCts insol
701
702 tyVarsOfImplic :: Implication -> TyVarSet
703 -- Only called on *zonked* things, hence no need to worry about flatten-skolems
704 tyVarsOfImplic (Implic { ic_skols = skols
705 , ic_given = givens, ic_wanted = wanted })
706 = (tyVarsOfWC wanted `unionVarSet` tyVarsOfTypes (map evVarPred givens))
707 `delVarSetList` skols
708
709 tyVarsOfBag :: (a -> TyVarSet) -> Bag a -> TyVarSet
710 tyVarsOfBag tvs_of = foldrBag (unionVarSet . tvs_of) emptyVarSet