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 ( lookupImportedName )
53 #include "HsVersions.h"
56 Typechecking instance declarations is done in two passes. The first
57 pass, made by @tcInstDecls1@, collects information to be used in the
60 This pre-processed info includes the as-yet-unprocessed bindings
61 inside the instance declaration. These are type-checked in the second
62 pass, when the class-instance envs and GVE contain all the info from
63 all the instance and value decls. Indeed that's the reason we need
64 two passes over the instance decls.
67 Note [How instance declarations are translated]
68 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
69 Here is how we translation instance declarations into Core
73 op1, op2 :: Ix b => a -> b -> b
77 {-# INLINE [2] op1 #-}
81 op1,op2 :: forall a. C a => forall b. Ix b => a -> b -> b
85 -- Default methods get the 'self' dictionary as argument
86 -- so they can call other methods at the same type
87 -- Default methods get the same type as their method selector
88 $dmop2 :: forall a. C a => forall b. Ix b => a -> b -> b
89 $dmop2 = /\a. \(d:C a). /\b. \(d2: Ix b). <dm-rhs>
90 -- NB: type variables 'a' and 'b' are *both* in scope in <dm-rhs>
91 -- Note [Tricky type variable scoping]
93 -- A top-level definition for each instance method
94 -- Here op1_i, op2_i are the "instance method Ids"
95 {-# INLINE [2] op1_i #-} -- From the instance decl bindings
96 op1_i, op2_i :: forall a. C a => forall b. Ix b => [a] -> b -> b
97 op1_i = /\a. \(d:C a).
98 let local_op1 :: forall a. (C a, C [a])
99 => forall b. Ix b => [a] -> b -> b
100 -- Note [Subtle interaction of recursion and overlap]
102 -- Source code; run the type checker on this
103 -- NB: Type variable 'a' (but not 'b') is in scope in <rhs>
104 -- Note [Tricky type variable scoping]
106 in local_op1 a d (df_i a d)
108 op2_i = /\a \d:C a. $dmop2 [a] (df_i a d)
110 -- The dictionary function itself
111 {-# INLINE df_i #-} -- Always inline dictionary functions
112 df_i :: forall a. C a -> C [a]
113 df_i = /\a. \d:C a. letrec d' = MkC (op1_i a d)
116 -- But see Note [Default methods in instances]
117 -- We can't apply the type checker to the default-method call
119 * The dictionary function itself is inlined as vigorously as we
120 possibly can, so that we expose that dictionary constructor to
121 selectors as much as poss. That is why the op_i stuff is in
122 *separate* bindings, so that the df_i binding is small enough
123 to inline. See Note [Inline dfuns unconditionally].
125 * Note that df_i may be mutually recursive with both op1_i and op2_i.
126 It's crucial that df_i is not chosen as the loop breaker, even
127 though op1_i has a (user-specified) INLINE pragma.
128 Not even once! Else op1_i, op2_i may be inlined into df_i.
130 * Instead the idea is to inline df_i into op1_i, which may then select
131 methods from the MkC record, and thereby break the recursion with
132 df_i, leaving a *self*-recurisve op1_i. (If op1_i doesn't call op at
133 the same type, it won't mention df_i, so there won't be recursion in
136 * If op1_i is marked INLINE by the user there's a danger that we won't
137 inline df_i in it, and that in turn means that (since it'll be a
138 loop-breaker because df_i isn't), op1_i will ironically never be
139 inlined. We need to fix this somehow -- perhaps allowing inlining
140 of INLINE funcitons inside other INLINE functions.
142 Note [Subtle interaction of recursion and overlap]
143 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
145 class C a where { op1,op2 :: a -> a }
146 instance C a => C [a] where
147 op1 x = op2 x ++ op2 x
149 intance C [Int] where
152 When type-checking the C [a] instance, we need a C [a] dictionary (for
153 the call of op2). If we look up in the instance environment, we find
154 an overlap. And in *general* the right thing is to complain (see Note
155 [Overlapping instances] in InstEnv). But in *this* case it's wrong to
156 complain, because we just want to delegate to the op2 of this same
159 Why is this justified? Because we generate a (C [a]) constraint in
160 a context in which 'a' cannot be instantiated to anything that matches
161 other overlapping instances, or else we would not be excecuting this
162 version of op1 in the first place.
164 It might even be a bit disguised:
166 nullFail :: C [a] => [a] -> [a]
167 nullFail x = op2 x ++ op2 x
169 instance C a => C [a] where
172 Precisely this is used in package 'regex-base', module Context.hs.
173 See the overlapping instances for RegexContext, and the fact that they
174 call 'nullFail' just like the example above. The DoCon package also
175 does the same thing; it shows up in module Fraction.hs
177 Conclusion: when typechecking the methods in a C [a] instance, we want
178 to have C [a] available. That is why we have the strange local let in
179 the definition of op1_i in the example above. We can typecheck the
180 defintion of local_op1, and then supply the "this" argument via an
181 explicit call to the dfun (which in turn will be inlined).
183 Note [Tricky type variable scoping]
184 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
187 op1, op2 :: Ix b => a -> b -> b
190 instance C a => C [a]
191 {-# INLINE [2] op1 #-}
194 note that 'a' and 'b' are *both* in scope in <dm-rhs>, but only 'a' is
195 in scope in <rhs>. In particular, we must make sure that 'b' is in
196 scope when typechecking <dm-rhs>. This is achieved by subFunTys,
197 which brings appropriate tyvars into scope. This happens for both
198 <dm-rhs> and for <rhs>, but that doesn't matter: the *renamer* will have
199 complained if 'b' is mentioned in <rhs>.
201 Note [Inline dfuns unconditionally]
202 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
203 The code above unconditionally inlines dict funs. Here's why.
204 Consider this program:
206 test :: Int -> Int -> Bool
207 test x y = (x,y) == (y,x) || test y x
208 -- Recursive to avoid making it inline.
210 This needs the (Eq (Int,Int)) instance. If we inline that dfun
211 the code we end up with is good:
214 \r -> case ==# [ww ww1] of wild {
215 PrelBase.False -> Test.$wtest ww1 ww;
217 case ==# [ww1 ww] of wild1 {
218 PrelBase.False -> Test.$wtest ww1 ww;
219 PrelBase.True -> PrelBase.True [];
222 Test.test = \r [w w1]
225 case w1 of w3 { PrelBase.I# ww1 -> Test.$wtest ww ww1; };
228 If we don't inline the dfun, the code is not nearly as good:
230 (==) = case PrelTup.$fEq(,) PrelBase.$fEqInt PrelBase.$fEqInt of tpl {
231 PrelBase.:DEq tpl1 tpl2 -> tpl2;
236 let { y = PrelBase.I#! [ww1]; } in
237 let { x = PrelBase.I#! [ww]; } in
238 let { sat_slx = PrelTup.(,)! [y x]; } in
239 let { sat_sly = PrelTup.(,)! [x y];
241 case == sat_sly sat_slx of wild {
242 PrelBase.False -> Test.$wtest ww1 ww;
243 PrelBase.True -> PrelBase.True [];
250 case w1 of w3 { PrelBase.I# ww1 -> Test.$wtest ww ww1; };
253 Why didn't GHC inline $fEq in those days? Because it looked big:
255 PrelTup.zdfEqZ1T{-rcX-}
256 = \ @ a{-reT-} :: * @ b{-reS-} :: *
257 zddEq{-rf6-} _Ks :: {PrelBase.Eq{-23-} a{-reT-}}
258 zddEq1{-rf7-} _Ks :: {PrelBase.Eq{-23-} b{-reS-}} ->
260 zeze{-rf0-} _Kl :: (b{-reS-} -> b{-reS-} -> PrelBase.Bool{-3c-})
261 zeze{-rf0-} = PrelBase.zeze{-01L-}@ b{-reS-} zddEq1{-rf7-} } in
263 zeze1{-rf3-} _Kl :: (a{-reT-} -> a{-reT-} -> PrelBase.Bool{-3c-})
264 zeze1{-rf3-} = PrelBase.zeze{-01L-} @ a{-reT-} zddEq{-rf6-} } in
266 zeze2{-reN-} :: ((a{-reT-}, b{-reS-}) -> (a{-reT-}, b{-reS-})-> PrelBase.Bool{-3c-})
267 zeze2{-reN-} = \ ds{-rf5-} _Ks :: (a{-reT-}, b{-reS-})
268 ds1{-rf4-} _Ks :: (a{-reT-}, b{-reS-}) ->
270 of wild{-reW-} _Kd { (a1{-rf2-} _Ks, a2{-reZ-} _Ks) ->
272 of wild1{-reX-} _Kd { (b1{-rf1-} _Ks, b2{-reY-} _Ks) ->
274 (zeze1{-rf3-} a1{-rf2-} b1{-rf1-})
275 (zeze{-rf0-} a2{-reZ-} b2{-reY-})
279 a1{-reR-} :: ((a{-reT-}, b{-reS-})-> (a{-reT-}, b{-reS-})-> PrelBase.Bool{-3c-})
280 a1{-reR-} = \ a2{-reV-} _Ks :: (a{-reT-}, b{-reS-})
281 b1{-reU-} _Ks :: (a{-reT-}, b{-reS-}) ->
282 PrelBase.not{-r6I-} (zeze2{-reN-} a2{-reV-} b1{-reU-})
284 PrelBase.zdwZCDEq{-r8J-} @ (a{-reT-}, b{-reS-}) a1{-reR-} zeze2{-reN-})
286 and it's not as bad as it seems, because it's further dramatically
287 simplified: only zeze2 is extracted and its body is simplified.
290 %************************************************************************
292 \subsection{Extracting instance decls}
294 %************************************************************************
296 Gather up the instance declarations from their various sources
299 tcInstDecls1 -- Deal with both source-code and imported instance decls
300 :: [LTyClDecl Name] -- For deriving stuff
301 -> [LInstDecl Name] -- Source code instance decls
302 -> [LDerivDecl Name] -- Source code stand-alone deriving decls
303 -> TcM (TcGblEnv, -- The full inst env
304 [InstInfo Name], -- Source-code instance decls to process;
305 -- contains all dfuns for this module
306 HsValBinds Name) -- Supporting bindings for derived instances
308 tcInstDecls1 tycl_decls inst_decls deriv_decls
310 do { -- Stop if addInstInfos etc discovers any errors
311 -- (they recover, so that we get more than one error each
314 -- (1) Do class and family instance declarations
315 ; let { idxty_decls = filter (isFamInstDecl . unLoc) tycl_decls }
316 ; local_info_tycons <- mapAndRecoverM tcLocalInstDecl1 inst_decls
317 ; idx_tycons <- mapAndRecoverM tcIdxTyInstDeclTL idxty_decls
320 at_tycons_s) = unzip local_info_tycons
321 ; at_idx_tycon = concat at_tycons_s ++ idx_tycons
322 ; clas_decls = filter (isClassDecl.unLoc) tycl_decls
323 ; implicit_things = concatMap implicitTyThings at_idx_tycon
326 -- (2) Add the tycons of indexed types and their implicit
327 -- tythings to the global environment
328 ; tcExtendGlobalEnv (at_idx_tycon ++ implicit_things) $ do {
330 -- (3) Instances from generic class declarations
331 ; generic_inst_info <- getGenericInstances clas_decls
333 -- Next, construct the instance environment so far, consisting
335 -- a) local instance decls
336 -- b) generic instances
337 -- c) local family instance decls
338 ; addInsts local_info $ do {
339 ; addInsts generic_inst_info $ do {
340 ; addFamInsts at_idx_tycon $ do {
342 -- (4) Compute instances from "deriving" clauses;
343 -- This stuff computes a context for the derived instance
344 -- decl, so it needs to know about all the instances possible
345 -- NB: class instance declarations can contain derivings as
346 -- part of associated data type declarations
347 failIfErrsM -- If the addInsts stuff gave any errors, don't
348 -- try the deriving stuff, becuase that may give
350 ; (deriv_inst_info, deriv_binds) <- tcDeriving tycl_decls inst_decls
352 ; addInsts deriv_inst_info $ do {
354 ; gbl_env <- getGblEnv
356 generic_inst_info ++ deriv_inst_info ++ local_info,
360 -- Make sure that toplevel type instance are not for associated types.
361 -- !!!TODO: Need to perform this check for the TyThing of type functions,
363 tcIdxTyInstDeclTL ldecl@(L loc decl) =
364 do { tything <- tcFamInstDecl ldecl
366 when (isAssocFamily tything) $
367 addErr $ assocInClassErr (tcdName decl)
370 isAssocFamily (ATyCon tycon) =
371 case tyConFamInst_maybe tycon of
372 Nothing -> panic "isAssocFamily: no family?!?"
373 Just (fam, _) -> isTyConAssoc fam
374 isAssocFamily _ = panic "isAssocFamily: no tycon?!?"
376 assocInClassErr :: Name -> SDoc
377 assocInClassErr name =
378 ptext (sLit "Associated type") <+> quotes (ppr name) <+>
379 ptext (sLit "must be inside a class instance")
381 addInsts :: [InstInfo Name] -> TcM a -> TcM a
382 addInsts infos thing_inside
383 = tcExtendLocalInstEnv (map iSpec infos) thing_inside
385 addFamInsts :: [TyThing] -> TcM a -> TcM a
386 addFamInsts tycons thing_inside
387 = tcExtendLocalFamInstEnv (map mkLocalFamInstTyThing tycons) thing_inside
389 mkLocalFamInstTyThing (ATyCon tycon) = mkLocalFamInst tycon
390 mkLocalFamInstTyThing tything = pprPanic "TcInstDcls.addFamInsts"
395 tcLocalInstDecl1 :: LInstDecl Name
396 -> TcM (InstInfo Name, [TyThing])
397 -- A source-file instance declaration
398 -- Type-check all the stuff before the "where"
400 -- We check for respectable instance type, and context
401 tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats))
403 addErrCtxt (instDeclCtxt1 poly_ty) $
405 do { is_boot <- tcIsHsBoot
406 ; checkTc (not is_boot || (isEmptyLHsBinds binds && null uprags))
409 ; (tyvars, theta, tau) <- tcHsInstHead poly_ty
411 -- Now, check the validity of the instance.
412 ; (clas, inst_tys) <- checkValidInstHead tau
413 ; checkValidInstance tyvars theta clas inst_tys
415 -- Next, process any associated types.
416 ; idx_tycons <- recoverM (return []) $
417 do { idx_tycons <- checkNoErrs $ mapAndRecoverM tcFamInstDecl ats
418 ; checkValidAndMissingATs clas (tyvars, inst_tys)
420 ; return idx_tycons }
422 -- Finally, construct the Core representation of the instance.
423 -- (This no longer includes the associated types.)
424 ; dfun_name <- newDFunName clas inst_tys (getLoc poly_ty)
425 -- Dfun location is that of instance *header*
426 ; overlap_flag <- getOverlapFlag
427 ; let (eq_theta,dict_theta) = partition isEqPred theta
428 theta' = eq_theta ++ dict_theta
429 dfun = mkDictFunId dfun_name tyvars theta' clas inst_tys
430 ispec = mkLocalInstance dfun overlap_flag
432 ; return (InstInfo { iSpec = ispec,
433 iBinds = VanillaInst binds uprags },
437 -- We pass in the source form and the type checked form of the ATs. We
438 -- really need the source form only to be able to produce more informative
440 checkValidAndMissingATs :: Class
441 -> ([TyVar], [TcType]) -- instance types
442 -> [(LTyClDecl Name, -- source form of AT
443 TyThing)] -- Core form of AT
445 checkValidAndMissingATs clas inst_tys ats
446 = do { -- Issue a warning for each class AT that is not defined in this
448 ; let class_ats = map tyConName (classATs clas)
449 defined_ats = listToNameSet . map (tcdName.unLoc.fst) $ ats
450 omitted = filterOut (`elemNameSet` defined_ats) class_ats
451 ; warn <- doptM Opt_WarnMissingMethods
452 ; mapM_ (warnTc warn . omittedATWarn) omitted
454 -- Ensure that all AT indexes that correspond to class parameters
455 -- coincide with the types in the instance head. All remaining
456 -- AT arguments must be variables. Also raise an error for any
457 -- type instances that are not associated with this class.
458 ; mapM_ (checkIndexes clas inst_tys) ats
461 checkIndexes clas inst_tys (hsAT, ATyCon tycon) =
462 -- !!!TODO: check that this does the Right Thing for indexed synonyms, too!
463 checkIndexes' clas inst_tys hsAT
465 snd . fromJust . tyConFamInst_maybe $ tycon)
466 checkIndexes _ _ _ = panic "checkIndexes"
468 checkIndexes' clas (instTvs, instTys) hsAT (atTvs, atTys)
469 = let atName = tcdName . unLoc $ hsAT
471 setSrcSpan (getLoc hsAT) $
472 addErrCtxt (atInstCtxt atName) $
473 case find ((atName ==) . tyConName) (classATs clas) of
474 Nothing -> addErrTc $ badATErr clas atName -- not in this class
476 case assocTyConArgPoss_maybe atDecl of
477 Nothing -> panic "checkIndexes': AT has no args poss?!?"
480 -- The following is tricky! We need to deal with three
481 -- complications: (1) The AT possibly only uses a subset of
482 -- the class parameters as indexes and those it uses may be in
483 -- a different order; (2) the AT may have extra arguments,
484 -- which must be type variables; and (3) variables in AT and
485 -- instance head will be different `Name's even if their
486 -- source lexemes are identical.
488 -- Re (1), `poss' contains a permutation vector to extract the
489 -- class parameters in the right order.
491 -- Re (2), we wrap the (permuted) class parameters in a Maybe
492 -- type and use Nothing for any extra AT arguments. (First
493 -- equation of `checkIndex' below.)
495 -- Re (3), we replace any type variable in the AT parameters
496 -- that has the same source lexeme as some variable in the
497 -- instance types with the instance type variable sharing its
500 let relevantInstTys = map (instTys !!) poss
501 instArgs = map Just relevantInstTys ++
502 repeat Nothing -- extra arguments
503 renaming = substSameTyVar atTvs instTvs
505 zipWithM_ checkIndex (substTys renaming atTys) instArgs
507 checkIndex ty Nothing
508 | isTyVarTy ty = return ()
509 | otherwise = addErrTc $ mustBeVarArgErr ty
510 checkIndex ty (Just instTy)
511 | ty `tcEqType` instTy = return ()
512 | otherwise = addErrTc $ wrongATArgErr ty instTy
514 listToNameSet = addListToNameSet emptyNameSet
516 substSameTyVar [] _ = emptyTvSubst
517 substSameTyVar (tv:tvs) replacingTvs =
518 let replacement = case find (tv `sameLexeme`) replacingTvs of
519 Nothing -> mkTyVarTy tv
520 Just rtv -> mkTyVarTy rtv
522 tv1 `sameLexeme` tv2 =
523 nameOccName (tyVarName tv1) == nameOccName (tyVarName tv2)
525 extendTvSubst (substSameTyVar tvs replacingTvs) tv replacement
529 %************************************************************************
531 Type-checking instance declarations, pass 2
533 %************************************************************************
536 tcInstDecls2 :: [LTyClDecl Name] -> [InstInfo Name]
537 -> TcM (LHsBinds Id, TcLclEnv)
538 -- (a) From each class declaration,
539 -- generate any default-method bindings
540 -- (b) From each instance decl
541 -- generate the dfun binding
543 tcInstDecls2 tycl_decls inst_decls
544 = do { -- (a) Default methods from class decls
545 (dm_binds_s, dm_ids_s) <- mapAndUnzipM tcClassDecl2 $
546 filter (isClassDecl.unLoc) tycl_decls
547 ; tcExtendIdEnv (concat dm_ids_s) $ do
549 -- (b) instance declarations
550 ; inst_binds_s <- mapM tcInstDecl2 inst_decls
553 ; let binds = unionManyBags dm_binds_s `unionBags`
554 unionManyBags inst_binds_s
555 ; tcl_env <- getLclEnv -- Default method Ids in here
556 ; return (binds, tcl_env) }
561 tcInstDecl2 :: InstInfo Name -> TcM (LHsBinds Id)
562 -- Returns a binding for the dfun
564 ------------------------
565 -- Derived newtype instances; surprisingly tricky!
567 -- class Show a => Foo a b where ...
568 -- newtype N a = MkN (Tree [a]) deriving( Foo Int )
570 -- The newtype gives an FC axiom looking like
571 -- axiom CoN a :: N a :=: Tree [a]
572 -- (see Note [Newtype coercions] in TyCon for this unusual form of axiom)
574 -- So all need is to generate a binding looking like:
575 -- dfunFooT :: forall a. (Foo Int (Tree [a], Show (N a)) => Foo Int (N a)
576 -- dfunFooT = /\a. \(ds:Show (N a)) (df:Foo (Tree [a])).
577 -- case df `cast` (Foo Int (sym (CoN a))) of
578 -- Foo _ op1 .. opn -> Foo ds op1 .. opn
580 -- If there are no superclasses, matters are simpler, because we don't need the case
581 -- see Note [Newtype deriving superclasses] in TcDeriv.lhs
583 tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = NewTypeDerived })
584 = do { let dfun_id = instanceDFunId ispec
585 rigid_info = InstSkol
586 origin = SigOrigin rigid_info
587 inst_ty = idType dfun_id
588 ; (tvs, theta, inst_head_ty) <- tcSkolSigType rigid_info inst_ty
589 -- inst_head_ty is a PredType
591 ; let (cls, cls_inst_tys) = tcSplitDFunHead inst_head_ty
592 (class_tyvars, sc_theta, _, _) = classBigSig cls
593 cls_tycon = classTyCon cls
594 sc_theta' = substTheta (zipOpenTvSubst class_tyvars cls_inst_tys) sc_theta
596 Just (initial_cls_inst_tys, last_ty) = snocView cls_inst_tys
597 (nt_tycon, tc_args) = tcSplitTyConApp last_ty -- Can't fail
598 rep_ty = newTyConInstRhs nt_tycon tc_args
600 rep_pred = mkClassPred cls (initial_cls_inst_tys ++ [rep_ty])
601 -- In our example, rep_pred is (Foo Int (Tree [a]))
602 the_coercion = make_coercion cls_tycon initial_cls_inst_tys nt_tycon tc_args
603 -- Coercion of kind (Foo Int (Tree [a]) ~ Foo Int (N a)
605 ; inst_loc <- getInstLoc origin
606 ; sc_loc <- getInstLoc InstScOrigin
607 ; dfun_dicts <- newDictBndrs inst_loc theta
608 ; sc_dicts <- newDictBndrs sc_loc sc_theta'
609 ; this_dict <- newDictBndr inst_loc (mkClassPred cls cls_inst_tys)
610 ; rep_dict <- newDictBndr inst_loc rep_pred
612 -- Figure out bindings for the superclass context from dfun_dicts
613 -- Don't include this_dict in the 'givens', else
614 -- wanted_sc_insts get bound by just selecting from this_dict!!
615 ; sc_binds <- addErrCtxt superClassCtxt $
616 tcSimplifySuperClasses inst_loc dfun_dicts (rep_dict:sc_dicts)
618 ; let coerced_rep_dict = wrapId the_coercion (instToId rep_dict)
620 ; body <- make_body cls_tycon cls_inst_tys sc_dicts coerced_rep_dict
621 ; let dict_bind = noLoc $ VarBind (instToId this_dict) (noLoc body)
623 ; return (unitBag $ noLoc $
624 AbsBinds tvs (map instToVar dfun_dicts)
625 [(tvs, dfun_id, instToId this_dict, [])]
626 (dict_bind `consBag` sc_binds)) }
628 -----------------------
630 -- The inst_head looks like (C s1 .. sm (T a1 .. ak))
631 -- But we want the coercion (C s1 .. sm (sym (CoT a1 .. ak)))
632 -- with kind (C s1 .. sm (T a1 .. ak) :=: C s1 .. sm <rep_ty>)
633 -- where rep_ty is the (eta-reduced) type rep of T
634 -- So we just replace T with CoT, and insert a 'sym'
635 -- NB: we know that k will be >= arity of CoT, because the latter fully eta-reduced
637 make_coercion cls_tycon initial_cls_inst_tys nt_tycon tc_args
638 | Just co_con <- newTyConCo_maybe nt_tycon
639 , let co = mkSymCoercion (mkTyConApp co_con tc_args)
640 = WpCast (mkTyConApp cls_tycon (initial_cls_inst_tys ++ [co]))
641 | otherwise -- The newtype is transparent; no need for a cast
644 -----------------------
645 -- (make_body C tys scs coreced_rep_dict)
647 -- (case coerced_rep_dict of { C _ ops -> C scs ops })
648 -- But if there are no superclasses, it returns just coerced_rep_dict
649 -- See Note [Newtype deriving superclasses] in TcDeriv.lhs
651 make_body cls_tycon cls_inst_tys sc_dicts coerced_rep_dict
652 | null sc_dicts -- Case (a)
653 = return coerced_rep_dict
654 | otherwise -- Case (b)
655 = do { op_ids <- newSysLocalIds (fsLit "op") op_tys
656 ; dummy_sc_dict_ids <- newSysLocalIds (fsLit "sc") (map idType sc_dict_ids)
657 ; let the_pat = ConPatOut { pat_con = noLoc cls_data_con, pat_tvs = [],
658 pat_dicts = dummy_sc_dict_ids,
659 pat_binds = emptyLHsBinds,
660 pat_args = PrefixCon (map nlVarPat op_ids),
662 the_match = mkSimpleMatch [noLoc the_pat] the_rhs
663 the_rhs = mkHsConApp cls_data_con cls_inst_tys $
664 map HsVar (sc_dict_ids ++ op_ids)
666 -- Warning: this HsCase scrutinises a value with a PredTy, which is
667 -- never otherwise seen in Haskell source code. It'd be
668 -- nicer to generate Core directly!
669 ; return (HsCase (noLoc coerced_rep_dict) $
670 MatchGroup [the_match] (mkFunTy pat_ty pat_ty)) }
672 sc_dict_ids = map instToId sc_dicts
673 pat_ty = mkTyConApp cls_tycon cls_inst_tys
674 cls_data_con = head (tyConDataCons cls_tycon)
675 cls_arg_tys = dataConInstArgTys cls_data_con cls_inst_tys
676 op_tys = dropList sc_dict_ids cls_arg_tys
678 ------------------------
679 -- Ordinary instances
681 tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags })
683 dfun_id = instanceDFunId ispec
684 rigid_info = InstSkol
685 inst_ty = idType dfun_id
686 loc = getSrcSpan dfun_id
688 -- Prime error recovery
689 recoverM (return emptyLHsBinds) $
691 addErrCtxt (instDeclCtxt2 (idType dfun_id)) $ do
693 -- Instantiate the instance decl with skolem constants
694 (inst_tyvars', dfun_theta', inst_head') <- tcSkolSigType rigid_info inst_ty
695 -- These inst_tyvars' scope over the 'where' part
696 -- Those tyvars are inside the dfun_id's type, which is a bit
697 -- bizarre, but OK so long as you realise it!
699 (clas, inst_tys') = tcSplitDFunHead inst_head'
700 (class_tyvars, sc_theta, _, op_items) = classBigSig clas
702 -- Instantiate the super-class context with inst_tys
703 sc_theta' = substTheta (zipOpenTvSubst class_tyvars inst_tys') sc_theta
704 (eq_sc_theta',dict_sc_theta') = partition isEqPred sc_theta'
705 origin = SigOrigin rigid_info
706 (eq_dfun_theta',dict_dfun_theta') = partition isEqPred dfun_theta'
708 -- Create dictionary Ids from the specified instance contexts.
709 sc_loc <- getInstLoc InstScOrigin
710 sc_dicts <- newDictBndrs sc_loc dict_sc_theta'
711 inst_loc <- getInstLoc origin
712 sc_covars <- mkMetaCoVars eq_sc_theta'
713 wanted_sc_eqs <- mkEqInsts eq_sc_theta' (map mkWantedCo sc_covars)
714 dfun_covars <- mkCoVars eq_dfun_theta'
715 dfun_eqs <- mkEqInsts eq_dfun_theta' (map mkGivenCo $ mkTyVarTys dfun_covars)
716 dfun_dicts <- newDictBndrs inst_loc dict_dfun_theta'
717 this_dict <- newDictBndr inst_loc (mkClassPred clas inst_tys')
718 -- Default-method Ids may be mentioned in synthesised RHSs,
719 -- but they'll already be in the environment.
721 -- Typecheck the methods
722 let -- These insts are in scope; quite a few, eh?
723 dfun_insts = dfun_eqs ++ dfun_dicts
724 wanted_sc_insts = wanted_sc_eqs ++ sc_dicts
725 this_dict_id = instToId this_dict
726 sc_dict_ids = map instToId sc_dicts
727 dfun_dict_ids = map instToId dfun_dicts
728 prag_fn = mkPragFun uprags
729 tc_meth = tcInstanceMethod loc clas inst_tyvars'
730 (dfun_covars ++ dfun_dict_ids)
731 dfun_theta' inst_tys'
734 (meth_exprs, meth_binds) <- mapAndUnzipM tc_meth op_items
736 -- Figure out bindings for the superclass context
737 -- Don't include this_dict in the 'givens', else
738 -- wanted_sc_insts get bound by just selecting from this_dict!!
739 sc_binds <- addErrCtxt superClassCtxt $
740 tcSimplifySuperClasses inst_loc dfun_insts
742 -- Note [Recursive superclasses]
744 -- It's possible that the superclass stuff might unified one
745 -- of the inst_tyavars' with something in the envt
746 checkSigTyVars inst_tyvars'
748 -- Deal with 'SPECIALISE instance' pragmas
749 prags <- tcPrags dfun_id (filter isSpecInstLSig uprags)
751 -- Create the result bindings
753 dict_constr = classDataCon clas
754 inline_prag | null dfun_insts = []
755 | otherwise = [L loc (InlinePrag (Inline AlwaysActive True))]
756 -- Always inline the dfun; this is an experimental decision
757 -- because it makes a big performance difference sometimes.
758 -- Often it means we can do the method selection, and then
759 -- inline the method as well. Marcin's idea; see comments below.
761 -- BUT: don't inline it if it's a constant dictionary;
762 -- we'll get all the benefit without inlining, and we get
763 -- a **lot** of code duplication if we inline it
765 -- See Note [Inline dfuns] below
767 dict_rhs = mkHsConApp dict_constr (inst_tys' ++ mkTyVarTys sc_covars)
768 (map HsVar sc_dict_ids ++ meth_exprs)
769 -- We don't produce a binding for the dict_constr; instead we
770 -- rely on the simplifier to unfold this saturated application
771 -- We do this rather than generate an HsCon directly, because
772 -- it means that the special cases (e.g. dictionary with only one
773 -- member) are dealt with by the common MkId.mkDataConWrapId code rather
774 -- than needing to be repeated here.
776 dict_bind = noLoc (VarBind this_dict_id dict_rhs)
778 main_bind = noLoc $ AbsBinds
779 (inst_tyvars' ++ dfun_covars)
781 [(inst_tyvars' ++ dfun_covars, dfun_id, this_dict_id, inline_prag ++ prags)]
782 (dict_bind `consBag` sc_binds)
784 showLIE (text "instance")
785 return (main_bind `consBag` unionManyBags meth_binds)
787 mkCoVars :: [PredType] -> TcM [TyVar]
788 mkCoVars = newCoVars . map unEqPred
790 unEqPred (EqPred ty1 ty2) = (ty1, ty2)
791 unEqPred _ = panic "TcInstDcls.mkCoVars"
793 mkMetaCoVars :: [PredType] -> TcM [TyVar]
794 mkMetaCoVars = mapM eqPredToCoVar
796 eqPredToCoVar (EqPred ty1 ty2) = newMetaCoVar ty1 ty2
797 eqPredToCoVar _ = panic "TcInstDcls.mkMetaCoVars"
800 Note [Recursive superclasses]
801 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
802 See Trac #1470 for why we would *like* to add "this_dict" to the
803 available instances here. But we can't do so because then the superclases
804 get satisfied by selection from this_dict, and that leads to an immediate
805 loop. What we need is to add this_dict to Avails without adding its
806 superclasses, and we currently have no way to do that.
809 %************************************************************************
811 Type-checking an instance method
813 %************************************************************************
816 - Make the method bindings, as a [(NonRec, HsBinds)], one per method
817 - Remembering to use fresh Name (the instance method Name) as the binder
818 - Bring the instance method Ids into scope, for the benefit of tcInstSig
819 - Use sig_fn mapping instance method Name -> instance tyvars
821 - Use tcValBinds to do the checking
824 tcInstanceMethod :: SrcSpan -> Class -> [TcTyVar] -> [Var]
825 -> TcThetaType -> [TcType]
827 -> TcPragFun -> LHsBinds Name
829 -> TcM (HsExpr Id, LHsBinds Id)
830 -- The returned inst_meth_ids all have types starting
831 -- forall tvs. theta => ...
833 tcInstanceMethod loc clas tyvars dfun_lam_vars theta inst_tys
835 prag_fn binds_in (sel_id, dm_info)
836 = do { uniq <- newUnique
837 ; let local_meth_name = mkInternalName uniq sel_occ loc -- Same OccName
838 tc_body = tcInstanceMethodBody clas tyvars dfun_lam_vars theta inst_tys
839 this_dict_id dfun_id sel_id
840 prags local_meth_name
842 ; case (findMethodBind sel_name local_meth_name binds_in, dm_info) of
843 -- There is a user-supplied method binding, so use it
844 (Just user_bind, _) -> tc_body user_bind
846 -- The user didn't supply a method binding, so we have to make
847 -- up a default binding, in a way depending on the default-method info
849 (Nothing, GenDefMeth) -> do -- Derivable type classes stuff
850 { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id local_meth_name
851 ; tc_body meth_bind }
853 (Nothing, NoDefMeth) -> do -- No default method in the class
854 { warn <- doptM Opt_WarnMissingMethods
855 ; warnTc (warn -- Warn only if -fwarn-missing-methods
856 && reportIfUnused (getOccName sel_id))
857 -- Don't warn about _foo methods
859 ; return (error_rhs, emptyBag) }
861 (Nothing, DefMeth) -> do -- An polymorphic default method
862 { -- Build the typechecked version directly,
863 -- without calling typecheck_method;
864 -- see Note [Default methods in instances]
865 dm_name <- lookupImportedName (mkDefMethRdrName sel_name)
866 -- Might not be imported, but will be an OrigName
867 ; dm_id <- tcLookupId dm_name
868 ; return (wrapId dm_wrapper dm_id, emptyBag) } }
870 sel_name = idName sel_id
871 sel_occ = nameOccName sel_name
872 prags = prag_fn sel_name
874 error_rhs = HsApp (mkLHsWrap (WpTyApp meth_tau) error_id) error_msg
875 meth_tau = funResultTy (applyTys (idType sel_id) inst_tys)
876 error_id = L loc (HsVar nO_METHOD_BINDING_ERROR_ID)
877 error_msg = L loc (HsLit (HsStringPrim (mkFastString error_string)))
878 error_string = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
880 dm_wrapper = WpApp this_dict_id <.> mkWpTyApps inst_tys
882 omitted_meth_warn :: SDoc
883 omitted_meth_warn = ptext (sLit "No explicit method nor default method for")
884 <+> quotes (ppr sel_id)
887 tcInstanceMethodBody :: Class -> [TcTyVar] -> [Var]
888 -> TcThetaType -> [TcType]
890 -> [LSig Name] -> Name -> LHsBind Name
891 -> TcM (HsExpr Id, LHsBinds Id)
892 tcInstanceMethodBody clas tyvars dfun_lam_vars theta inst_tys
893 this_dict_id dfun_id sel_id
894 prags local_meth_name bind@(L loc _)
895 = do { uniq <- newUnique
896 ; let (sel_tyvars,sel_rho) = tcSplitForAllTys (idType sel_id)
897 rho_ty = ASSERT( length sel_tyvars == length inst_tys )
898 substTyWith sel_tyvars inst_tys sel_rho
900 (first_pred, meth_tau) = tcSplitPredFunTy_maybe rho_ty
901 `orElse` pprPanic "tcInstanceMethod" (ppr sel_id)
903 meth_name = mkInternalName uniq (getOccName local_meth_name) loc
904 meth_ty = mkSigmaTy tyvars theta meth_tau
905 meth_id = mkLocalId meth_name meth_ty
907 local_meth_ty = mkSigmaTy tyvars (theta ++ [first_pred]) meth_tau
908 local_meth_id = mkLocalId local_meth_name local_meth_ty
910 tv_names = map tyVarName tyvars
912 -- The first predicate should be of form (C a b)
913 -- where C is the class in question
914 ; MASSERT( case getClassPredTys_maybe first_pred of
915 { Just (clas1, _tys) -> clas == clas1 ; Nothing -> False } )
917 ; local_meth_bind <- tcMethodBind tv_names prags local_meth_id bind
919 ; let full_bind = unitBag $ L loc $
920 VarBind meth_id $ L loc $
921 mkHsWrap (mkWpTyLams tyvars <.> mkWpLams dfun_lam_vars) $
922 HsLet (HsValBinds (ValBindsOut [(NonRecursive, local_meth_bind)] [])) $ L loc $
923 mkHsWrap (WpLet this_dict_bind <.> WpApp this_dict_id) $
924 wrapId meth_wrapper local_meth_id
925 this_dict_bind = unitBag $ L loc $
926 VarBind this_dict_id $ L loc $
927 wrapId meth_wrapper dfun_id
929 ; return (wrapId meth_wrapper meth_id, full_bind) }
931 meth_wrapper = mkWpApps dfun_lam_vars <.> mkWpTyApps (mkTyVarTys tyvars)
933 wrapId :: HsWrapper -> id -> HsExpr id
934 wrapId wrapper id = mkHsWrap wrapper (HsVar id)
937 Note [Default methods in instances]
938 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
947 From the class decl we get
949 $dmfoo :: forall v x. Baz v x => x -> x
951 Notice that the type is ambiguous. That's fine, though. The instance decl generates
953 $dBazIntInt = MkBaz ($dmfoo Int Int $dBazIntInt)
955 BUT this does mean we must generate the dictionary translation directly, rather
956 than generating source-code and type-checking it. That was the bug ing
957 Trac #1061. In any case it's less work to generate the translated version!
960 %************************************************************************
962 \subsection{Error messages}
964 %************************************************************************
967 instDeclCtxt1 :: LHsType Name -> SDoc
968 instDeclCtxt1 hs_inst_ty
969 = inst_decl_ctxt (case unLoc hs_inst_ty of
970 HsForAllTy _ _ _ (L _ (HsPredTy pred)) -> ppr pred
971 HsPredTy pred -> ppr pred
972 _ -> ppr hs_inst_ty) -- Don't expect this
973 instDeclCtxt2 :: Type -> SDoc
974 instDeclCtxt2 dfun_ty
975 = inst_decl_ctxt (ppr (mkClassPred cls tys))
977 (_,_,cls,tys) = tcSplitDFunTy dfun_ty
979 inst_decl_ctxt :: SDoc -> SDoc
980 inst_decl_ctxt doc = ptext (sLit "In the instance declaration for") <+> quotes doc
982 superClassCtxt :: SDoc
983 superClassCtxt = ptext (sLit "When checking the super-classes of an instance declaration")
985 atInstCtxt :: Name -> SDoc
986 atInstCtxt name = ptext (sLit "In the associated type instance for") <+>
989 mustBeVarArgErr :: Type -> SDoc
991 sep [ ptext (sLit "Arguments that do not correspond to a class parameter") <+>
992 ptext (sLit "must be variables")
993 , ptext (sLit "Instead of a variable, found") <+> ppr ty
996 wrongATArgErr :: Type -> Type -> SDoc
997 wrongATArgErr ty instTy =
998 sep [ ptext (sLit "Type indexes must match class instance head")
999 , ptext (sLit "Found") <+> ppr ty <+> ptext (sLit "but expected") <+>