2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
6 TcInstDecls: Typechecking instance declarations
9 module TcInstDcls ( tcInstDecls1, tcInstDecls2 ) where
24 import RnEnv ( lookupGlobalOccRn )
25 import RnSource ( addTcgDUs )
35 import CoreUnfold ( mkDFunUnfolding )
36 import PrelNames ( inlineIdName )
54 #include "HsVersions.h"
57 Typechecking instance declarations is done in two passes. The first
58 pass, made by @tcInstDecls1@, collects information to be used in the
61 This pre-processed info includes the as-yet-unprocessed bindings
62 inside the instance declaration. These are type-checked in the second
63 pass, when the class-instance envs and GVE contain all the info from
64 all the instance and value decls. Indeed that's the reason we need
65 two passes over the instance decls.
68 Note [How instance declarations are translated]
69 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
70 Here is how we translation instance declarations into Core
74 op1, op2 :: Ix b => a -> b -> b
78 {-# INLINE [2] op1 #-}
82 op1,op2 :: forall a. C a => forall b. Ix b => a -> b -> b
86 -- Default methods get the 'self' dictionary as argument
87 -- so they can call other methods at the same type
88 -- Default methods get the same type as their method selector
89 $dmop2 :: forall a. C a => forall b. Ix b => a -> b -> b
90 $dmop2 = /\a. \(d:C a). /\b. \(d2: Ix b). <dm-rhs>
91 -- NB: type variables 'a' and 'b' are *both* in scope in <dm-rhs>
92 -- Note [Tricky type variable scoping]
94 -- A top-level definition for each instance method
95 -- Here op1_i, op2_i are the "instance method Ids"
96 -- The INLINE pragma comes from the user pragma
97 {-# INLINE [2] op1_i #-} -- From the instance decl bindings
98 op1_i, op2_i :: forall a. C a => forall b. Ix b => [a] -> b -> b
99 op1_i = /\a. \(d:C a).
102 -- Note [Subtle interaction of recursion and overlap]
104 local_op1 :: forall b. Ix b => [a] -> b -> b
106 -- Source code; run the type checker on this
107 -- NB: Type variable 'a' (but not 'b') is in scope in <rhs>
108 -- Note [Tricky type variable scoping]
112 op2_i = /\a \d:C a. $dmop2 [a] (df_i a d)
114 -- The dictionary function itself
115 {-# NOINLINE CONLIKE df_i #-} -- Never inline dictionary functions
116 df_i :: forall a. C a -> C [a]
117 df_i = /\a. \d:C a. MkC (op1_i a d) (op2_i a d)
118 -- But see Note [Default methods in instances]
119 -- We can't apply the type checker to the default-method call
121 -- Use a RULE to short-circuit applications of the class ops
122 {-# RULE "op1@C[a]" forall a, d:C a.
123 op1 [a] (df_i d) = op1_i a d #-}
125 * We want to inline the dictionary function itself as vigorously as we
126 possibly can, so that we expose that dictionary constructor to
127 selectors as much as poss. We don't actually inline it; rather, we
128 use a Builtin RULE for the ClassOps (see MkId.mkDictSelId) to short
129 circuit such applications. But the RULE only applies if it can "see"
130 the dfun's DFunUnfolding.
132 * Note that df_i may be mutually recursive with both op1_i and op2_i.
133 It's crucial that df_i is not chosen as the loop breaker, even
134 though op1_i has a (user-specified) INLINE pragma.
136 * Instead the idea is to inline df_i into op1_i, which may then select
137 methods from the MkC record, and thereby break the recursion with
138 df_i, leaving a *self*-recurisve op1_i. (If op1_i doesn't call op at
139 the same type, it won't mention df_i, so there won't be recursion in
142 * If op1_i is marked INLINE by the user there's a danger that we won't
143 inline df_i in it, and that in turn means that (since it'll be a
144 loop-breaker because df_i isn't), op1_i will ironically never be
145 inlined. But this is OK: the recursion breaking happens by way of
146 a RULE (the magic ClassOp rule above), and RULES work inside InlineRule
147 unfoldings. See Note [RULEs enabled in SimplGently] in SimplUtils
150 Note [Subtle interaction of recursion and overlap]
151 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
153 class C a where { op1,op2 :: a -> a }
154 instance C a => C [a] where
155 op1 x = op2 x ++ op2 x
157 intance C [Int] where
160 When type-checking the C [a] instance, we need a C [a] dictionary (for
161 the call of op2). If we look up in the instance environment, we find
162 an overlap. And in *general* the right thing is to complain (see Note
163 [Overlapping instances] in InstEnv). But in *this* case it's wrong to
164 complain, because we just want to delegate to the op2 of this same
167 Why is this justified? Because we generate a (C [a]) constraint in
168 a context in which 'a' cannot be instantiated to anything that matches
169 other overlapping instances, or else we would not be excecuting this
170 version of op1 in the first place.
172 It might even be a bit disguised:
174 nullFail :: C [a] => [a] -> [a]
175 nullFail x = op2 x ++ op2 x
177 instance C a => C [a] where
180 Precisely this is used in package 'regex-base', module Context.hs.
181 See the overlapping instances for RegexContext, and the fact that they
182 call 'nullFail' just like the example above. The DoCon package also
183 does the same thing; it shows up in module Fraction.hs
185 Conclusion: when typechecking the methods in a C [a] instance, we want
186 to have C [a] available. That is why we have the strange local
187 definition for 'this' in the definition of op1_i in the example above.
188 We can typecheck the defintion of local_op1, and when doing tcSimplifyCheck
189 we supply 'this' as a given dictionary. Only needed, though, if there
190 are some type variables involved; otherwise there can be no overlap and
193 Note [Tricky type variable scoping]
194 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
197 op1, op2 :: Ix b => a -> b -> b
200 instance C a => C [a]
201 {-# INLINE [2] op1 #-}
204 note that 'a' and 'b' are *both* in scope in <dm-rhs>, but only 'a' is
205 in scope in <rhs>. In particular, we must make sure that 'b' is in
206 scope when typechecking <dm-rhs>. This is achieved by subFunTys,
207 which brings appropriate tyvars into scope. This happens for both
208 <dm-rhs> and for <rhs>, but that doesn't matter: the *renamer* will have
209 complained if 'b' is mentioned in <rhs>.
211 Note [Inline dfuns unconditionally]
212 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
213 The code above unconditionally inlines dict funs. Here's why.
214 Consider this program:
216 test :: Int -> Int -> Bool
217 test x y = (x,y) == (y,x) || test y x
218 -- Recursive to avoid making it inline.
220 This needs the (Eq (Int,Int)) instance. If we inline that dfun
221 the code we end up with is good:
224 \r -> case ==# [ww ww1] of wild {
225 PrelBase.False -> Test.$wtest ww1 ww;
227 case ==# [ww1 ww] of wild1 {
228 PrelBase.False -> Test.$wtest ww1 ww;
229 PrelBase.True -> PrelBase.True [];
232 Test.test = \r [w w1]
235 case w1 of w3 { PrelBase.I# ww1 -> Test.$wtest ww ww1; };
238 If we don't inline the dfun, the code is not nearly as good:
240 (==) = case PrelTup.$fEq(,) PrelBase.$fEqInt PrelBase.$fEqInt of tpl {
241 PrelBase.:DEq tpl1 tpl2 -> tpl2;
246 let { y = PrelBase.I#! [ww1]; } in
247 let { x = PrelBase.I#! [ww]; } in
248 let { sat_slx = PrelTup.(,)! [y x]; } in
249 let { sat_sly = PrelTup.(,)! [x y];
251 case == sat_sly sat_slx of wild {
252 PrelBase.False -> Test.$wtest ww1 ww;
253 PrelBase.True -> PrelBase.True [];
260 case w1 of w3 { PrelBase.I# ww1 -> Test.$wtest ww ww1; };
263 Why didn't GHC inline $fEq in those days? Because it looked big:
265 PrelTup.zdfEqZ1T{-rcX-}
266 = \ @ a{-reT-} :: * @ b{-reS-} :: *
267 zddEq{-rf6-} _Ks :: {PrelBase.Eq{-23-} a{-reT-}}
268 zddEq1{-rf7-} _Ks :: {PrelBase.Eq{-23-} b{-reS-}} ->
270 zeze{-rf0-} _Kl :: (b{-reS-} -> b{-reS-} -> PrelBase.Bool{-3c-})
271 zeze{-rf0-} = PrelBase.zeze{-01L-}@ b{-reS-} zddEq1{-rf7-} } in
273 zeze1{-rf3-} _Kl :: (a{-reT-} -> a{-reT-} -> PrelBase.Bool{-3c-})
274 zeze1{-rf3-} = PrelBase.zeze{-01L-} @ a{-reT-} zddEq{-rf6-} } in
276 zeze2{-reN-} :: ((a{-reT-}, b{-reS-}) -> (a{-reT-}, b{-reS-})-> PrelBase.Bool{-3c-})
277 zeze2{-reN-} = \ ds{-rf5-} _Ks :: (a{-reT-}, b{-reS-})
278 ds1{-rf4-} _Ks :: (a{-reT-}, b{-reS-}) ->
280 of wild{-reW-} _Kd { (a1{-rf2-} _Ks, a2{-reZ-} _Ks) ->
282 of wild1{-reX-} _Kd { (b1{-rf1-} _Ks, b2{-reY-} _Ks) ->
284 (zeze1{-rf3-} a1{-rf2-} b1{-rf1-})
285 (zeze{-rf0-} a2{-reZ-} b2{-reY-})
289 a1{-reR-} :: ((a{-reT-}, b{-reS-})-> (a{-reT-}, b{-reS-})-> PrelBase.Bool{-3c-})
290 a1{-reR-} = \ a2{-reV-} _Ks :: (a{-reT-}, b{-reS-})
291 b1{-reU-} _Ks :: (a{-reT-}, b{-reS-}) ->
292 PrelBase.not{-r6I-} (zeze2{-reN-} a2{-reV-} b1{-reU-})
294 PrelBase.zdwZCDEq{-r8J-} @ (a{-reT-}, b{-reS-}) a1{-reR-} zeze2{-reN-})
296 and it's not as bad as it seems, because it's further dramatically
297 simplified: only zeze2 is extracted and its body is simplified.
300 %************************************************************************
302 \subsection{Extracting instance decls}
304 %************************************************************************
306 Gather up the instance declarations from their various sources
309 tcInstDecls1 -- Deal with both source-code and imported instance decls
310 :: [LTyClDecl Name] -- For deriving stuff
311 -> [LInstDecl Name] -- Source code instance decls
312 -> [LDerivDecl Name] -- Source code stand-alone deriving decls
313 -> TcM (TcGblEnv, -- The full inst env
314 [InstInfo Name], -- Source-code instance decls to process;
315 -- contains all dfuns for this module
316 HsValBinds Name) -- Supporting bindings for derived instances
318 tcInstDecls1 tycl_decls inst_decls deriv_decls
320 do { -- Stop if addInstInfos etc discovers any errors
321 -- (they recover, so that we get more than one error each
324 -- (1) Do class and family instance declarations
325 ; let { idxty_decls = filter (isFamInstDecl . unLoc) tycl_decls }
326 ; local_info_tycons <- mapAndRecoverM tcLocalInstDecl1 inst_decls
327 ; idx_tycons <- mapAndRecoverM tcIdxTyInstDeclTL idxty_decls
330 at_tycons_s) = unzip local_info_tycons
331 ; at_idx_tycons = concat at_tycons_s ++ idx_tycons
332 ; clas_decls = filter (isClassDecl.unLoc) tycl_decls
333 ; implicit_things = concatMap implicitTyThings at_idx_tycons
334 ; aux_binds = mkAuxBinds at_idx_tycons
337 -- (2) Add the tycons of indexed types and their implicit
338 -- tythings to the global environment
339 ; tcExtendGlobalEnv (at_idx_tycons ++ implicit_things) $ do {
341 -- (3) Instances from generic class declarations
342 ; generic_inst_info <- getGenericInstances clas_decls
344 -- Next, construct the instance environment so far, consisting
346 -- a) local instance decls
347 -- b) generic instances
348 -- c) local family instance decls
349 ; addInsts local_info $
350 addInsts generic_inst_info $
351 addFamInsts at_idx_tycons $ do {
353 -- (4) Compute instances from "deriving" clauses;
354 -- This stuff computes a context for the derived instance
355 -- decl, so it needs to know about all the instances possible
356 -- NB: class instance declarations can contain derivings as
357 -- part of associated data type declarations
358 failIfErrsM -- If the addInsts stuff gave any errors, don't
359 -- try the deriving stuff, becuase that may give
361 ; (deriv_inst_info, deriv_binds, deriv_dus)
362 <- tcDeriving tycl_decls inst_decls deriv_decls
363 ; gbl_env <- addInsts deriv_inst_info getGblEnv
364 ; return ( addTcgDUs gbl_env deriv_dus,
365 generic_inst_info ++ deriv_inst_info ++ local_info,
366 aux_binds `plusHsValBinds` deriv_binds)
369 -- Make sure that toplevel type instance are not for associated types.
370 -- !!!TODO: Need to perform this check for the TyThing of type functions,
372 tcIdxTyInstDeclTL ldecl@(L loc decl) =
373 do { tything <- tcFamInstDecl ldecl
375 when (isAssocFamily tything) $
376 addErr $ assocInClassErr (tcdName decl)
379 isAssocFamily (ATyCon tycon) =
380 case tyConFamInst_maybe tycon of
381 Nothing -> panic "isAssocFamily: no family?!?"
382 Just (fam, _) -> isTyConAssoc fam
383 isAssocFamily _ = panic "isAssocFamily: no tycon?!?"
385 assocInClassErr :: Name -> SDoc
386 assocInClassErr name =
387 ptext (sLit "Associated type") <+> quotes (ppr name) <+>
388 ptext (sLit "must be inside a class instance")
390 addInsts :: [InstInfo Name] -> TcM a -> TcM a
391 addInsts infos thing_inside
392 = tcExtendLocalInstEnv (map iSpec infos) thing_inside
394 addFamInsts :: [TyThing] -> TcM a -> TcM a
395 addFamInsts tycons thing_inside
396 = tcExtendLocalFamInstEnv (map mkLocalFamInstTyThing tycons) thing_inside
398 mkLocalFamInstTyThing (ATyCon tycon) = mkLocalFamInst tycon
399 mkLocalFamInstTyThing tything = pprPanic "TcInstDcls.addFamInsts"
404 tcLocalInstDecl1 :: LInstDecl Name
405 -> TcM (InstInfo Name, [TyThing])
406 -- A source-file instance declaration
407 -- Type-check all the stuff before the "where"
409 -- We check for respectable instance type, and context
410 tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats))
412 addErrCtxt (instDeclCtxt1 poly_ty) $
414 do { is_boot <- tcIsHsBoot
415 ; checkTc (not is_boot || (isEmptyLHsBinds binds && null uprags))
418 ; (tyvars, theta, tau) <- tcHsInstHead poly_ty
420 -- Now, check the validity of the instance.
421 ; (clas, inst_tys) <- checkValidInstHead tau
422 ; checkValidInstance tyvars theta clas inst_tys
424 -- Next, process any associated types.
425 ; idx_tycons <- recoverM (return []) $
426 do { idx_tycons <- checkNoErrs $ mapAndRecoverM tcFamInstDecl ats
427 ; checkValidAndMissingATs clas (tyvars, inst_tys)
429 ; return idx_tycons }
431 -- Finally, construct the Core representation of the instance.
432 -- (This no longer includes the associated types.)
433 ; dfun_name <- newDFunName clas inst_tys (getLoc poly_ty)
434 -- Dfun location is that of instance *header*
435 ; overlap_flag <- getOverlapFlag
436 ; let (eq_theta,dict_theta) = partition isEqPred theta
437 theta' = eq_theta ++ dict_theta
438 dfun = mkDictFunId dfun_name tyvars theta' clas inst_tys
439 ispec = mkLocalInstance dfun overlap_flag
441 ; return (InstInfo { iSpec = ispec,
442 iBinds = VanillaInst binds uprags False },
446 -- We pass in the source form and the type checked form of the ATs. We
447 -- really need the source form only to be able to produce more informative
449 checkValidAndMissingATs :: Class
450 -> ([TyVar], [TcType]) -- instance types
451 -> [(LTyClDecl Name, -- source form of AT
452 TyThing)] -- Core form of AT
454 checkValidAndMissingATs clas inst_tys ats
455 = do { -- Issue a warning for each class AT that is not defined in this
457 ; let class_ats = map tyConName (classATs clas)
458 defined_ats = listToNameSet . map (tcdName.unLoc.fst) $ ats
459 omitted = filterOut (`elemNameSet` defined_ats) class_ats
460 ; warn <- doptM Opt_WarnMissingMethods
461 ; mapM_ (warnTc warn . omittedATWarn) omitted
463 -- Ensure that all AT indexes that correspond to class parameters
464 -- coincide with the types in the instance head. All remaining
465 -- AT arguments must be variables. Also raise an error for any
466 -- type instances that are not associated with this class.
467 ; mapM_ (checkIndexes clas inst_tys) ats
470 checkIndexes clas inst_tys (hsAT, ATyCon tycon)
471 -- !!!TODO: check that this does the Right Thing for indexed synonyms, too!
472 = checkIndexes' clas inst_tys hsAT
474 snd . fromJust . tyConFamInst_maybe $ tycon)
475 checkIndexes _ _ _ = panic "checkIndexes"
477 checkIndexes' clas (instTvs, instTys) hsAT (atTvs, atTys)
478 = let atName = tcdName . unLoc $ hsAT
480 setSrcSpan (getLoc hsAT) $
481 addErrCtxt (atInstCtxt atName) $
482 case find ((atName ==) . tyConName) (classATs clas) of
483 Nothing -> addErrTc $ badATErr clas atName -- not in this class
485 case assocTyConArgPoss_maybe atycon of
486 Nothing -> panic "checkIndexes': AT has no args poss?!?"
489 -- The following is tricky! We need to deal with three
490 -- complications: (1) The AT possibly only uses a subset of
491 -- the class parameters as indexes and those it uses may be in
492 -- a different order; (2) the AT may have extra arguments,
493 -- which must be type variables; and (3) variables in AT and
494 -- instance head will be different `Name's even if their
495 -- source lexemes are identical.
497 -- e.g. class C a b c where
498 -- data D b a :: * -> * -- NB (1) b a, omits c
499 -- instance C [x] Bool Char where
500 -- data D Bool [x] v = MkD x [v] -- NB (2) v
501 -- -- NB (3) the x in 'instance C...' have differnt
502 -- -- Names to x's in 'data D...'
504 -- Re (1), `poss' contains a permutation vector to extract the
505 -- class parameters in the right order.
507 -- Re (2), we wrap the (permuted) class parameters in a Maybe
508 -- type and use Nothing for any extra AT arguments. (First
509 -- equation of `checkIndex' below.)
511 -- Re (3), we replace any type variable in the AT parameters
512 -- that has the same source lexeme as some variable in the
513 -- instance types with the instance type variable sharing its
516 let relevantInstTys = map (instTys !!) poss
517 instArgs = map Just relevantInstTys ++
518 repeat Nothing -- extra arguments
519 renaming = substSameTyVar atTvs instTvs
521 zipWithM_ checkIndex (substTys renaming atTys) instArgs
523 checkIndex ty Nothing
524 | isTyVarTy ty = return ()
525 | otherwise = addErrTc $ mustBeVarArgErr ty
526 checkIndex ty (Just instTy)
527 | ty `tcEqType` instTy = return ()
528 | otherwise = addErrTc $ wrongATArgErr ty instTy
530 listToNameSet = addListToNameSet emptyNameSet
532 substSameTyVar [] _ = emptyTvSubst
533 substSameTyVar (tv:tvs) replacingTvs =
534 let replacement = case find (tv `sameLexeme`) replacingTvs of
535 Nothing -> mkTyVarTy tv
536 Just rtv -> mkTyVarTy rtv
538 tv1 `sameLexeme` tv2 =
539 nameOccName (tyVarName tv1) == nameOccName (tyVarName tv2)
541 extendTvSubst (substSameTyVar tvs replacingTvs) tv replacement
545 %************************************************************************
547 Type-checking instance declarations, pass 2
549 %************************************************************************
552 tcInstDecls2 :: [LTyClDecl Name] -> [InstInfo Name]
553 -> TcM (LHsBinds Id, TcLclEnv)
554 -- (a) From each class declaration,
555 -- generate any default-method bindings
556 -- (b) From each instance decl
557 -- generate the dfun binding
559 tcInstDecls2 tycl_decls inst_decls
560 = do { -- (a) Default methods from class decls
561 let class_decls = filter (isClassDecl . unLoc) tycl_decls
562 ; (dm_ids_s, dm_binds_s) <- mapAndUnzipM tcClassDecl2 class_decls
564 ; tcExtendIdEnv (concat dm_ids_s) $ do
566 -- (b) instance declarations
567 { inst_binds_s <- mapM tcInstDecl2 inst_decls
570 ; let binds = unionManyBags dm_binds_s `unionBags`
571 unionManyBags inst_binds_s
572 ; tcl_env <- getLclEnv -- Default method Ids in here
573 ; return (binds, tcl_env) } }
575 tcInstDecl2 :: InstInfo Name -> TcM (LHsBinds Id)
576 tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
577 = recoverM (return emptyLHsBinds) $
579 addErrCtxt (instDeclCtxt2 (idType dfun_id)) $
580 tc_inst_decl2 dfun_id ibinds
582 dfun_id = instanceDFunId ispec
583 loc = getSrcSpan dfun_id
588 tc_inst_decl2 :: Id -> InstBindings Name -> TcM (LHsBinds Id)
589 -- Returns a binding for the dfun
591 ------------------------
592 -- Derived newtype instances; surprisingly tricky!
594 -- class Show a => Foo a b where ...
595 -- newtype N a = MkN (Tree [a]) deriving( Foo Int )
597 -- The newtype gives an FC axiom looking like
598 -- axiom CoN a :: N a ~ Tree [a]
599 -- (see Note [Newtype coercions] in TyCon for this unusual form of axiom)
601 -- So all need is to generate a binding looking like:
602 -- dfunFooT :: forall a. (Foo Int (Tree [a], Show (N a)) => Foo Int (N a)
603 -- dfunFooT = /\a. \(ds:Show (N a)) (df:Foo (Tree [a])).
604 -- case df `cast` (Foo Int (sym (CoN a))) of
605 -- Foo _ op1 .. opn -> Foo ds op1 .. opn
607 -- If there are no superclasses, matters are simpler, because we don't need the case
608 -- see Note [Newtype deriving superclasses] in TcDeriv.lhs
610 tc_inst_decl2 dfun_id (NewTypeDerived coi)
611 = do { let rigid_info = InstSkol
612 origin = SigOrigin rigid_info
613 inst_ty = idType dfun_id
614 inst_tvs = fst (tcSplitForAllTys inst_ty)
615 ; (inst_tvs', theta, inst_head_ty) <- tcSkolSigType rigid_info inst_ty
616 -- inst_head_ty is a PredType
618 ; let (cls, cls_inst_tys) = tcSplitDFunHead inst_head_ty
619 (class_tyvars, sc_theta, _, _) = classBigSig cls
620 cls_tycon = classTyCon cls
621 sc_theta' = substTheta (zipOpenTvSubst class_tyvars cls_inst_tys) sc_theta
622 Just (initial_cls_inst_tys, last_ty) = snocView cls_inst_tys
626 IdCo -> (last_ty, idHsWrapper)
627 ACo co -> (snd (coercionKind co'), WpCast (mk_full_coercion co'))
629 co' = substTyWith inst_tvs (mkTyVarTys inst_tvs') co
630 -- NB: the free variable of coi are bound by the
631 -- universally quantified variables of the dfun_id
632 -- This is weird, and maybe we should make NewTypeDerived
633 -- carry a type-variable list too; but it works fine
635 -----------------------
637 -- The inst_head looks like (C s1 .. sm (T a1 .. ak))
638 -- But we want the coercion (C s1 .. sm (sym (CoT a1 .. ak)))
639 -- with kind (C s1 .. sm (T a1 .. ak) ~ C s1 .. sm <rep_ty>)
640 -- where rep_ty is the (eta-reduced) type rep of T
641 -- So we just replace T with CoT, and insert a 'sym'
642 -- NB: we know that k will be >= arity of CoT, because the latter fully eta-reduced
644 mk_full_coercion co = mkTyConApp cls_tycon
645 (initial_cls_inst_tys ++ [mkSymCoercion co])
646 -- Full coercion : (Foo Int (Tree [a]) ~ Foo Int (N a)
648 rep_pred = mkClassPred cls (initial_cls_inst_tys ++ [rep_ty])
649 -- In our example, rep_pred is (Foo Int (Tree [a]))
651 ; sc_loc <- getInstLoc InstScOrigin
652 ; sc_dicts <- newDictBndrs sc_loc sc_theta'
653 ; inst_loc <- getInstLoc origin
654 ; dfun_dicts <- newDictBndrs inst_loc theta
655 ; rep_dict <- newDictBndr inst_loc rep_pred
656 ; this_dict <- newDictBndr inst_loc (mkClassPred cls cls_inst_tys)
658 -- Figure out bindings for the superclass context from dfun_dicts
659 -- Don't include this_dict in the 'givens', else
660 -- sc_dicts get bound by just selecting from this_dict!!
661 ; sc_binds <- addErrCtxt superClassCtxt $
662 tcSimplifySuperClasses inst_loc this_dict dfun_dicts
665 -- It's possible that the superclass stuff might unified something
666 -- in the envt with one of the clas_tyvars
667 ; checkSigTyVars inst_tvs'
669 ; let coerced_rep_dict = wrapId wrapper (instToId rep_dict)
671 ; body <- make_body cls_tycon cls_inst_tys sc_dicts coerced_rep_dict
672 ; let dict_bind = mkVarBind (instToId this_dict) (noLoc body)
674 ; return (unitBag $ noLoc $
675 AbsBinds inst_tvs' (map instToVar dfun_dicts)
676 [(inst_tvs', dfun_id, instToId this_dict, [])]
677 (dict_bind `consBag` sc_binds)) }
679 -----------------------
680 -- (make_body C tys scs coreced_rep_dict)
682 -- (case coerced_rep_dict of { C _ ops -> C scs ops })
683 -- But if there are no superclasses, it returns just coerced_rep_dict
684 -- See Note [Newtype deriving superclasses] in TcDeriv.lhs
686 make_body cls_tycon cls_inst_tys sc_dicts coerced_rep_dict
687 | null sc_dicts -- Case (a)
688 = return coerced_rep_dict
689 | otherwise -- Case (b)
690 = do { op_ids <- newSysLocalIds (fsLit "op") op_tys
691 ; dummy_sc_dict_ids <- newSysLocalIds (fsLit "sc") (map idType sc_dict_ids)
692 ; let the_pat = ConPatOut { pat_con = noLoc cls_data_con, pat_tvs = [],
693 pat_dicts = dummy_sc_dict_ids,
694 pat_binds = emptyLHsBinds,
695 pat_args = PrefixCon (map nlVarPat op_ids),
697 the_match = mkSimpleMatch [noLoc the_pat] the_rhs
698 the_rhs = mkHsConApp cls_data_con cls_inst_tys $
699 map HsVar (sc_dict_ids ++ op_ids)
701 -- Warning: this HsCase scrutinises a value with a PredTy, which is
702 -- never otherwise seen in Haskell source code. It'd be
703 -- nicer to generate Core directly!
704 ; return (HsCase (noLoc coerced_rep_dict) $
705 MatchGroup [the_match] (mkFunTy pat_ty pat_ty)) }
707 sc_dict_ids = map instToId sc_dicts
708 pat_ty = mkTyConApp cls_tycon cls_inst_tys
709 cls_data_con = head (tyConDataCons cls_tycon)
710 cls_arg_tys = dataConInstArgTys cls_data_con cls_inst_tys
711 op_tys = dropList sc_dict_ids cls_arg_tys
713 ------------------------
714 -- Ordinary instances
716 tc_inst_decl2 dfun_id (VanillaInst monobinds uprags standalone_deriv)
717 = do { let rigid_info = InstSkol
718 inst_ty = idType dfun_id
719 loc = getSrcSpan dfun_id
721 -- Instantiate the instance decl with skolem constants
722 ; (inst_tyvars', dfun_theta', inst_head') <- tcSkolSigType rigid_info inst_ty
723 -- These inst_tyvars' scope over the 'where' part
724 -- Those tyvars are inside the dfun_id's type, which is a bit
725 -- bizarre, but OK so long as you realise it!
727 (clas, inst_tys') = tcSplitDFunHead inst_head'
728 (class_tyvars, sc_theta, sc_sels, op_items) = classBigSig clas
730 -- Instantiate the super-class context with inst_tys
731 sc_theta' = substTheta (zipOpenTvSubst class_tyvars inst_tys') sc_theta
732 origin = SigOrigin rigid_info
734 -- Create dictionary Ids from the specified instance contexts.
735 ; inst_loc <- getInstLoc origin
736 ; dfun_dicts <- newDictBndrs inst_loc dfun_theta' -- Includes equalities
737 ; this_dict <- newDictBndr inst_loc (mkClassPred clas inst_tys')
738 -- Default-method Ids may be mentioned in synthesised RHSs,
739 -- but they'll already be in the environment.
742 -- Cook up a binding for "this = df d1 .. dn",
743 -- to use in each method binding
744 -- Need to clone the dict in case it is floated out, and
745 -- then clashes with its friends
746 ; cloned_this <- cloneDict this_dict
747 ; let cloned_this_bind = mkVarBind (instToId cloned_this) $
748 L loc $ wrapId app_wrapper dfun_id
749 app_wrapper = mkWpApps dfun_lam_vars <.> mkWpTyApps (mkTyVarTys inst_tyvars')
750 dfun_lam_vars = map instToVar dfun_dicts -- Includes equalities
752 | null inst_tyvars' && null dfun_theta' = (this_dict, emptyBag)
753 | otherwise = (cloned_this, unitBag cloned_this_bind)
755 -- Deal with 'SPECIALISE instance' pragmas
756 -- See Note [SPECIALISE instance pragmas]
757 ; let spec_inst_sigs = filter isSpecInstLSig uprags
758 -- The filter removes the pragmas for methods
759 ; spec_inst_prags <- mapM (wrapLocM (tcSpecInst dfun_id)) spec_inst_sigs
761 -- Typecheck the methods
762 ; let prag_fn = mkPragFun uprags
763 tc_meth = tcInstanceMethod loc standalone_deriv
767 prag_fn spec_inst_prags monobinds
769 ; (meth_ids, meth_binds) <- tcExtendTyVarEnv inst_tyvars' $
770 mapAndUnzipM tc_meth op_items
772 -- Figure out bindings for the superclass context
773 ; sc_loc <- getInstLoc InstScOrigin
774 ; sc_dicts <- newDictOccs sc_loc sc_theta' -- These are wanted
775 ; let tc_sc = tcSuperClass inst_loc inst_tyvars' dfun_dicts nested_this_pair
776 ; (sc_ids, sc_binds) <- mapAndUnzipM tc_sc (sc_sels `zip` sc_dicts)
778 -- It's possible that the superclass stuff might unified
779 -- something in the envt with one of the inst_tyvars'
780 ; checkSigTyVars inst_tyvars'
782 -- Create the result bindings
783 ; let dict_constr = classDataCon clas
784 this_dict_id = instToId this_dict
785 dict_bind = mkVarBind this_dict_id dict_rhs
786 dict_rhs = foldl mk_app inst_constr (sc_ids ++ meth_ids)
787 inst_constr = L loc $ wrapId (mkWpTyApps inst_tys')
788 (dataConWrapId dict_constr)
789 -- We don't produce a binding for the dict_constr; instead we
790 -- rely on the simplifier to unfold this saturated application
791 -- We do this rather than generate an HsCon directly, because
792 -- it means that the special cases (e.g. dictionary with only one
793 -- member) are dealt with by the common MkId.mkDataConWrapId code rather
794 -- than needing to be repeated here.
796 mk_app :: LHsExpr Id -> Id -> LHsExpr Id
797 mk_app fun arg_id = L loc (HsApp fun (L loc (wrapId arg_wrapper arg_id)))
798 arg_wrapper = mkWpApps dfun_lam_vars <.> mkWpTyApps (mkTyVarTys inst_tyvars')
800 dfun_id_w_fun = dfun_id
801 `setIdUnfolding` mkDFunUnfolding dict_constr (sc_ids ++ meth_ids)
802 `setInlinePragma` dfunInlinePragma
804 main_bind = noLoc $ AbsBinds
807 [(inst_tyvars', dfun_id_w_fun, this_dict_id, spec_inst_prags)]
810 ; showLIE (text "instance")
811 ; return (unitBag main_bind `unionBags`
812 listToBag meth_binds `unionBags`
813 listToBag sc_binds) }
816 ------------------------------
817 tcSuperClass :: InstLoc -> [TyVar] -> [Inst]
818 -> (Inst, LHsBinds Id)
819 -> (Id, Inst) -> TcM (Id, LHsBind Id)
820 -- Build a top level decl like
821 -- sc_op = /\a \d. let this = ... in
824 -- The "this" part is just-in-case (discarded if not used)
825 -- See Note [Recursive superclasses]
826 tcSuperClass inst_loc tyvars dicts (this_dict, this_bind)
828 = addErrCtxt superClassCtxt $
829 do { sc_binds <- tcSimplifySuperClasses inst_loc
830 this_dict dicts [sc_dict]
831 -- Don't include this_dict in the 'givens', else
832 -- sc_dicts get bound by just selecting from this_dict!!
835 ; let sc_op_ty = mkSigmaTy tyvars (map dictPred dicts)
836 (mkPredTy (dictPred sc_dict))
837 sc_op_name = mkDerivedInternalName mkClassOpAuxOcc uniq
839 sc_op_id = mkLocalId sc_op_name sc_op_ty
840 sc_id = instToVar sc_dict
841 sc_op_bind = AbsBinds tyvars
842 (map instToVar dicts)
843 [(tyvars, sc_op_id, sc_id, [])]
844 (this_bind `unionBags` sc_binds)
846 ; return (sc_op_id, noLoc sc_op_bind) }
849 Note [Recursive superclasses]
850 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
851 See Trac #1470 for why we would *like* to add "this_dict" to the
852 available instances here. But we can't do so because then the superclases
853 get satisfied by selection from this_dict, and that leads to an immediate
854 loop. What we need is to add this_dict to Avails without adding its
855 superclasses, and we currently have no way to do that.
857 Note [SPECIALISE instance pragmas]
858 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
861 instance (Ix a, Ix b) => Ix (a,b) where
862 {-# SPECIALISE instance Ix (Int,Int) #-}
865 We do *not* want to make a specialised version of the dictionary
866 function. Rather, we want specialised versions of each method.
867 Thus we should generate something like this:
869 $dfIx :: (Ix a, Ix x) => Ix (a,b)
870 {- DFUN [$crange, ...] -}
871 $dfIx da db = Ix ($crange da db) (...other methods...)
873 $dfIxPair :: (Ix a, Ix x) => Ix (a,b)
874 {- DFUN [$crangePair, ...] -}
875 $dfIxPair = Ix ($crangePair da db) (...other methods...)
877 $crange :: (Ix a, Ix b) -> ((a,b),(a,b)) -> [(a,b)]
878 {-# SPECIALISE $crange :: ((Int,Int),(Int,Int)) -> [(Int,Int)] #-}
879 $crange da db = <blah>
881 {-# RULE range ($dfIx da db) = $crange da db #-}
885 * The RULE is unaffected by the specialisation. We don't want to
886 specialise $dfIx, because then it would need a specialised RULE
887 which is a pain. The single RULE works fine at all specialisations.
888 See Note [How instance declarations are translated] above
890 * Instead, we want to specialise the *method*, $crange
892 In practice, rather than faking up a SPECIALISE pragama for each
893 method (which is painful, since we'd have to figure out its
894 specialised type), we call tcSpecPrag *as if* were going to specialise
895 $dfIx -- you can see that in the call to tcSpecInst. That generates a
896 SpecPrag which, as it turns out, can be used unchanged for each method.
897 The "it turns out" bit is delicate, but it works fine!
900 tcSpecInst :: Id -> Sig Name -> TcM SpecPrag
901 tcSpecInst dfun_id prag@(SpecInstSig hs_ty)
902 = addErrCtxt (spec_ctxt prag) $
903 do { let name = idName dfun_id
904 ; (tyvars, theta, tau) <- tcHsInstHead hs_ty
905 ; let spec_ty = mkSigmaTy tyvars theta tau
906 ; co_fn <- tcSubExp (SpecPragOrigin name) (idType dfun_id) spec_ty
907 ; return (SpecPrag co_fn defaultInlinePragma) }
909 spec_ctxt prag = hang (ptext (sLit "In the SPECIALISE pragma")) 2 (ppr prag)
911 tcSpecInst _ _ = panic "tcSpecInst"
914 %************************************************************************
916 Type-checking an instance method
918 %************************************************************************
921 - Make the method bindings, as a [(NonRec, HsBinds)], one per method
922 - Remembering to use fresh Name (the instance method Name) as the binder
923 - Bring the instance method Ids into scope, for the benefit of tcInstSig
924 - Use sig_fn mapping instance method Name -> instance tyvars
926 - Use tcValBinds to do the checking
929 tcInstanceMethod :: SrcSpan -> Bool -> Class -> [TcTyVar] -> [Inst]
931 -> (Inst, LHsBinds Id) -- "This" and its binding
932 -> TcPragFun -- Local prags
933 -> [LSpecPrag] -- Arising from 'SPECLALISE instance'
936 -> TcM (Id, LHsBind Id)
937 -- The returned inst_meth_ids all have types starting
938 -- forall tvs. theta => ...
940 tcInstanceMethod loc standalone_deriv clas tyvars dfun_dicts inst_tys
941 (this_dict, this_dict_bind)
942 prag_fn spec_inst_prags binds_in (sel_id, dm_info)
943 = do { uniq <- newUnique
944 ; let meth_name = mkDerivedInternalName mkClassOpAuxOcc uniq sel_name
945 ; local_meth_name <- newLocalName sel_name
946 -- Base the local_meth_name on the selector name, becuase
947 -- type errors from tcInstanceMethodBody come from here
949 ; let local_meth_ty = instantiateMethod clas sel_id inst_tys
950 meth_ty = mkSigmaTy tyvars (map dictPred dfun_dicts) local_meth_ty
951 meth_id = mkLocalId meth_name meth_ty
952 local_meth_id = mkLocalId local_meth_name local_meth_ty
956 = add_meth_ctxt rn_bind $
957 do { (meth_id1, spec_prags) <- tcPrags NonRecursive False True
958 meth_id (prag_fn sel_name)
959 ; tcInstanceMethodBody (instLoc this_dict)
961 ([this_dict], this_dict_bind)
962 meth_id1 local_meth_id
964 (spec_inst_prags ++ spec_prags)
968 tc_default :: DefMeth -> TcM (Id, LHsBind Id)
969 -- The user didn't supply a method binding, so we have to make
970 -- up a default binding, in a way depending on the default-method info
972 tc_default NoDefMeth -- No default method at all
973 = do { warnMissingMethod sel_id
974 ; return (meth_id, mkVarBind meth_id $
975 mkLHsWrap lam_wrapper error_rhs) }
977 tc_default GenDefMeth -- Derivable type classes stuff
978 = do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id local_meth_name
979 ; tc_body meth_bind }
981 tc_default DefMeth -- An polymorphic default method
982 = do { -- Build the typechecked version directly,
983 -- without calling typecheck_method;
984 -- see Note [Default methods in instances]
985 -- Generate /\as.\ds. let this = df as ds
986 -- in $dm inst_tys this
987 -- The 'let' is necessary only because HsSyn doesn't allow
988 -- you to apply a function to a dictionary *expression*.
989 dm_name <- lookupGlobalOccRn (mkDefMethRdrName sel_name)
990 -- Might not be imported, but will be an OrigName
991 ; dm_id <- tcLookupId dm_name
992 ; inline_id <- tcLookupId inlineIdName
993 ; let dm_inline_prag = idInlinePragma dm_id
994 dm_app = HsWrap (WpApp (instToId this_dict) <.> mkWpTyApps inst_tys) $
996 rhs | isInlinePragma dm_inline_prag -- See Note [INLINE and default methods]
997 = HsApp (L loc (HsWrap (WpTyApp local_meth_ty) (HsVar inline_id)))
1001 meth_bind = L loc $ VarBind { var_id = local_meth_id
1002 , var_rhs = L loc rhs
1003 , var_inline = False }
1004 meth_id1 = meth_id `setInlinePragma` dm_inline_prag
1005 -- Copy the inline pragma (if any) from the default
1006 -- method to this version. Note [INLINE and default methods]
1008 bind = AbsBinds { abs_tvs = tyvars, abs_dicts = dfun_lam_vars
1009 , abs_exports = [( tyvars, meth_id1
1010 , local_meth_id, spec_inst_prags)]
1011 , abs_binds = this_dict_bind `unionBags` unitBag meth_bind }
1012 -- Default methods in an instance declaration can't have their own
1013 -- INLINE or SPECIALISE pragmas. It'd be possible to allow them, but
1014 -- currently they are rejected with
1015 -- "INLINE pragma lacks an accompanying binding"
1017 ; return (meth_id1, L loc bind) }
1019 ; case findMethodBind sel_name local_meth_name binds_in of
1020 Just user_bind -> tc_body user_bind -- User-supplied method binding
1021 Nothing -> tc_default dm_info -- None supplied
1024 sel_name = idName sel_id
1026 meth_sig_fn _ = Just [] -- The 'Just' says "yes, there's a type sig"
1027 -- But there are no scoped type variables from local_method_id
1028 -- Only the ones from the instance decl itself, which are already
1029 -- in scope. Example:
1030 -- class C a where { op :: forall b. Eq b => ... }
1031 -- instance C [c] where { op = <rhs> }
1032 -- In <rhs>, 'c' is scope but 'b' is not!
1034 error_rhs = L loc $ HsApp error_fun error_msg
1035 error_fun = L loc $ wrapId (WpTyApp meth_tau) nO_METHOD_BINDING_ERROR_ID
1036 error_msg = L loc (HsLit (HsStringPrim (mkFastString error_string)))
1037 meth_tau = funResultTy (applyTys (idType sel_id) inst_tys)
1038 error_string = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
1040 dfun_lam_vars = map instToVar dfun_dicts
1041 lam_wrapper = mkWpTyLams tyvars <.> mkWpLams dfun_lam_vars
1043 -- For instance decls that come from standalone deriving clauses
1044 -- we want to print out the full source code if there's an error
1045 -- because otherwise the user won't see the code at all
1046 add_meth_ctxt rn_bind thing
1047 | standalone_deriv = addLandmarkErrCtxt (derivBindCtxt clas inst_tys rn_bind) thing
1050 wrapId :: HsWrapper -> id -> HsExpr id
1051 wrapId wrapper id = mkHsWrap wrapper (HsVar id)
1053 derivBindCtxt :: Class -> [Type ] -> LHsBind Name -> SDoc
1054 derivBindCtxt clas tys bind
1055 = vcat [ ptext (sLit "When typechecking a standalone-derived method for")
1056 <+> quotes (pprClassPred clas tys) <> colon
1057 , nest 2 $ pprSetDepth AllTheWay $ ppr bind ]
1059 warnMissingMethod :: Id -> TcM ()
1060 warnMissingMethod sel_id
1061 = do { warn <- doptM Opt_WarnMissingMethods
1062 ; warnTc (warn -- Warn only if -fwarn-missing-methods
1063 && not (startsWithUnderscore (getOccName sel_id)))
1064 -- Don't warn about _foo methods
1065 (ptext (sLit "No explicit method nor default method for")
1066 <+> quotes (ppr sel_id)) }
1069 Note [Export helper functions]
1070 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1071 We arrange to export the "helper functions" of an instance declaration,
1072 so that they are not subject to preInlineUnconditionally, even if their
1073 RHS is trivial. Reason: they are mentioned in the DFunUnfolding of
1074 the dict fun as Ids, not as CoreExprs, so we can't substitute a
1075 non-variable for them.
1077 We could change this by making DFunUnfoldings have CoreExprs, but it
1078 seems a bit simpler this way.
1080 Note [Default methods in instances]
1081 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1088 instance Baz Int Int
1090 From the class decl we get
1092 $dmfoo :: forall v x. Baz v x => x -> x
1095 Notice that the type is ambiguous. That's fine, though. The instance decl generates
1097 $dBazIntInt = MkBaz fooIntInt
1098 fooIntInt = $dmfoo Int Int $dBazIntInt
1100 BUT this does mean we must generate the dictionary translation of
1101 fooIntInt directly, rather than generating source-code and
1102 type-checking it. That was the bug in Trac #1061. In any case it's
1103 less work to generate the translated version!
1105 Note [INLINE and default methods]
1106 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1107 We *copy* any INLINE pragma from the default method to the instance.
1110 op1, op2 :: Bool -> a -> a
1113 op1 b x = op2 (not b) x
1115 instance Foo Int where
1120 {-# INLINE $dmop1 #-}
1121 $dmop1 d b x = op2 d (not b) x
1123 $fFooInt = MkD $cop1 $cop2
1125 {-# INLINE $cop1 #-}
1126 $cop1 = inline $dmop1 $fFooInt
1131 a) We copy $dmop1's inline pragma to $cop1. Otherwise
1132 we'll just inline the former in the latter and stop, which
1133 isn't what the user expected
1135 b) We use the magic 'inline' Id to ensure that $dmop1 really is
1136 inlined in $cop1, even though the latter itself has an INLINE pragma
1137 That is important to allow the mutual recursion between $fooInt and
1140 This is all regrettably delicate.
1143 %************************************************************************
1145 \subsection{Error messages}
1147 %************************************************************************
1150 instDeclCtxt1 :: LHsType Name -> SDoc
1151 instDeclCtxt1 hs_inst_ty
1152 = inst_decl_ctxt (case unLoc hs_inst_ty of
1153 HsForAllTy _ _ _ (L _ (HsPredTy pred)) -> ppr pred
1154 HsPredTy pred -> ppr pred
1155 _ -> ppr hs_inst_ty) -- Don't expect this
1156 instDeclCtxt2 :: Type -> SDoc
1157 instDeclCtxt2 dfun_ty
1158 = inst_decl_ctxt (ppr (mkClassPred cls tys))
1160 (_,cls,tys) = tcSplitDFunTy dfun_ty
1162 inst_decl_ctxt :: SDoc -> SDoc
1163 inst_decl_ctxt doc = ptext (sLit "In the instance declaration for") <+> quotes doc
1165 superClassCtxt :: SDoc
1166 superClassCtxt = ptext (sLit "When checking the super-classes of an instance declaration")
1168 atInstCtxt :: Name -> SDoc
1169 atInstCtxt name = ptext (sLit "In the associated type instance for") <+>
1172 mustBeVarArgErr :: Type -> SDoc
1173 mustBeVarArgErr ty =
1174 sep [ ptext (sLit "Arguments that do not correspond to a class parameter") <+>
1175 ptext (sLit "must be variables")
1176 , ptext (sLit "Instead of a variable, found") <+> ppr ty
1179 wrongATArgErr :: Type -> Type -> SDoc
1180 wrongATArgErr ty instTy =
1181 sep [ ptext (sLit "Type indexes must match class instance head")
1182 , ptext (sLit "Found") <+> quotes (ppr ty)
1183 <+> ptext (sLit "but expected") <+> quotes (ppr instTy)