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 = <rhs> -- Source code; run the type checker on this
98 -- NB: Type variable 'a' (but not 'b') is in scope in <rhs>
99 -- Note [Tricky type variable scoping]
101 op2_i = /\a \d:C a. $dmop2 [a] (df_i a d)
103 -- The dictionary function itself
104 {-# INLINE df_i #-} -- Always inline dictionary functions
105 df_i :: forall a. C a -> C [a]
106 df_i = /\a. \d:C a. MkC (op1_i a d) ($dmop2 a d)
107 -- But see Note [Default methods in instances]
108 -- We can't apply the type checker to the default-nmethod call
110 * The dictionary function itself is inlined as vigorously as we
111 possibly can, so that we expose that dictionary constructor to
112 selectors as much as poss. That is why the op_i stuff is in
113 *separate* bindings, so that the df_i binding is small enough
114 to inline. See Note [Inline dfuns unconditionally].
116 * Note that df_i may be mutually recursive with both op1_i and op2_i.
117 It's crucial that df_i is not chosen as the loop breaker, even
118 though op1_i has a (user-specified) INLINE pragma.
119 Not even once! Else op1_i, op2_i may be inlined into df_i.
121 * Instead the idea is to inline df_i into op1_i, which may then select
122 methods from the MkC record, and thereby break the recursion with
123 df_i, leaving a *self*-recurisve op1_i. (If op1_i doesn't call op at
124 the same type, it won't mention df_i, so there won't be recursion in
127 * If op1_i is marked INLINE by the user there's a danger that we won't
128 inline df_i in it, and that in turn means that (since it'll be a
129 loop-breaker because df_i isn't), op1_i will ironically never be
130 inlined. We need to fix this somehow -- perhaps allowing inlining
131 of INLINE funcitons inside other INLINE functions.
133 Note [Tricky type variable scoping]
134 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
137 op1, op2 :: Ix b => a -> b -> b
140 instance C a => C [a]
141 {-# INLINE [2] op1 #-}
144 note that 'a' and 'b' are *both* in scope in <dm-rhs>, but only 'a' is
145 in scope in <rhs>. In particular, we must make sure that 'b' is in
146 scope when typechecking <dm-rhs>. This is achieved by subFunTys,
147 which brings appropriate tyvars into scope. This happens for both
148 <dm-rhs> and for <rhs>, but that doesn't matter: the *renamer* will have
149 complained if 'b' is mentioned in <rhs>.
151 Note [Inline dfuns unconditionally]
152 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
153 The code above unconditionally inlines dict funs. Here's why.
154 Consider this program:
156 test :: Int -> Int -> Bool
157 test x y = (x,y) == (y,x) || test y x
158 -- Recursive to avoid making it inline.
160 This needs the (Eq (Int,Int)) instance. If we inline that dfun
161 the code we end up with is good:
164 \r -> case ==# [ww ww1] of wild {
165 PrelBase.False -> Test.$wtest ww1 ww;
167 case ==# [ww1 ww] of wild1 {
168 PrelBase.False -> Test.$wtest ww1 ww;
169 PrelBase.True -> PrelBase.True [];
172 Test.test = \r [w w1]
175 case w1 of w3 { PrelBase.I# ww1 -> Test.$wtest ww ww1; };
178 If we don't inline the dfun, the code is not nearly as good:
180 (==) = case PrelTup.$fEq(,) PrelBase.$fEqInt PrelBase.$fEqInt of tpl {
181 PrelBase.:DEq tpl1 tpl2 -> tpl2;
186 let { y = PrelBase.I#! [ww1]; } in
187 let { x = PrelBase.I#! [ww]; } in
188 let { sat_slx = PrelTup.(,)! [y x]; } in
189 let { sat_sly = PrelTup.(,)! [x y];
191 case == sat_sly sat_slx of wild {
192 PrelBase.False -> Test.$wtest ww1 ww;
193 PrelBase.True -> PrelBase.True [];
200 case w1 of w3 { PrelBase.I# ww1 -> Test.$wtest ww ww1; };
203 Why didn't GHC inline $fEq in those days? Because it looked big:
205 PrelTup.zdfEqZ1T{-rcX-}
206 = \ @ a{-reT-} :: * @ b{-reS-} :: *
207 zddEq{-rf6-} _Ks :: {PrelBase.Eq{-23-} a{-reT-}}
208 zddEq1{-rf7-} _Ks :: {PrelBase.Eq{-23-} b{-reS-}} ->
210 zeze{-rf0-} _Kl :: (b{-reS-} -> b{-reS-} -> PrelBase.Bool{-3c-})
211 zeze{-rf0-} = PrelBase.zeze{-01L-}@ b{-reS-} zddEq1{-rf7-} } in
213 zeze1{-rf3-} _Kl :: (a{-reT-} -> a{-reT-} -> PrelBase.Bool{-3c-})
214 zeze1{-rf3-} = PrelBase.zeze{-01L-} @ a{-reT-} zddEq{-rf6-} } in
216 zeze2{-reN-} :: ((a{-reT-}, b{-reS-}) -> (a{-reT-}, b{-reS-})-> PrelBase.Bool{-3c-})
217 zeze2{-reN-} = \ ds{-rf5-} _Ks :: (a{-reT-}, b{-reS-})
218 ds1{-rf4-} _Ks :: (a{-reT-}, b{-reS-}) ->
220 of wild{-reW-} _Kd { (a1{-rf2-} _Ks, a2{-reZ-} _Ks) ->
222 of wild1{-reX-} _Kd { (b1{-rf1-} _Ks, b2{-reY-} _Ks) ->
224 (zeze1{-rf3-} a1{-rf2-} b1{-rf1-})
225 (zeze{-rf0-} a2{-reZ-} b2{-reY-})
229 a1{-reR-} :: ((a{-reT-}, b{-reS-})-> (a{-reT-}, b{-reS-})-> PrelBase.Bool{-3c-})
230 a1{-reR-} = \ a2{-reV-} _Ks :: (a{-reT-}, b{-reS-})
231 b1{-reU-} _Ks :: (a{-reT-}, b{-reS-}) ->
232 PrelBase.not{-r6I-} (zeze2{-reN-} a2{-reV-} b1{-reU-})
234 PrelBase.zdwZCDEq{-r8J-} @ (a{-reT-}, b{-reS-}) a1{-reR-} zeze2{-reN-})
236 and it's not as bad as it seems, because it's further dramatically
237 simplified: only zeze2 is extracted and its body is simplified.
240 %************************************************************************
242 \subsection{Extracting instance decls}
244 %************************************************************************
246 Gather up the instance declarations from their various sources
249 tcInstDecls1 -- Deal with both source-code and imported instance decls
250 :: [LTyClDecl Name] -- For deriving stuff
251 -> [LInstDecl Name] -- Source code instance decls
252 -> [LDerivDecl Name] -- Source code stand-alone deriving decls
253 -> TcM (TcGblEnv, -- The full inst env
254 [InstInfo Name], -- Source-code instance decls to process;
255 -- contains all dfuns for this module
256 HsValBinds Name) -- Supporting bindings for derived instances
258 tcInstDecls1 tycl_decls inst_decls deriv_decls
260 do { -- Stop if addInstInfos etc discovers any errors
261 -- (they recover, so that we get more than one error each
264 -- (1) Do class and family instance declarations
265 ; let { idxty_decls = filter (isFamInstDecl . unLoc) tycl_decls }
266 ; local_info_tycons <- mapAndRecoverM tcLocalInstDecl1 inst_decls
267 ; idx_tycons <- mapAndRecoverM tcIdxTyInstDeclTL idxty_decls
270 at_tycons_s) = unzip local_info_tycons
271 ; at_idx_tycon = concat at_tycons_s ++ idx_tycons
272 ; clas_decls = filter (isClassDecl.unLoc) tycl_decls
273 ; implicit_things = concatMap implicitTyThings at_idx_tycon
276 -- (2) Add the tycons of indexed types and their implicit
277 -- tythings to the global environment
278 ; tcExtendGlobalEnv (at_idx_tycon ++ implicit_things) $ do {
280 -- (3) Instances from generic class declarations
281 ; generic_inst_info <- getGenericInstances clas_decls
283 -- Next, construct the instance environment so far, consisting
285 -- a) local instance decls
286 -- b) generic instances
287 -- c) local family instance decls
288 ; addInsts local_info $ do {
289 ; addInsts generic_inst_info $ do {
290 ; addFamInsts at_idx_tycon $ do {
292 -- (4) Compute instances from "deriving" clauses;
293 -- This stuff computes a context for the derived instance
294 -- decl, so it needs to know about all the instances possible
295 -- NB: class instance declarations can contain derivings as
296 -- part of associated data type declarations
297 failIfErrsM -- If the addInsts stuff gave any errors, don't
298 -- try the deriving stuff, becuase that may give
300 ; (deriv_inst_info, deriv_binds) <- tcDeriving tycl_decls inst_decls
302 ; addInsts deriv_inst_info $ do {
304 ; gbl_env <- getGblEnv
306 generic_inst_info ++ deriv_inst_info ++ local_info,
310 -- Make sure that toplevel type instance are not for associated types.
311 -- !!!TODO: Need to perform this check for the TyThing of type functions,
313 tcIdxTyInstDeclTL ldecl@(L loc decl) =
314 do { tything <- tcFamInstDecl ldecl
316 when (isAssocFamily tything) $
317 addErr $ assocInClassErr (tcdName decl)
320 isAssocFamily (ATyCon tycon) =
321 case tyConFamInst_maybe tycon of
322 Nothing -> panic "isAssocFamily: no family?!?"
323 Just (fam, _) -> isTyConAssoc fam
324 isAssocFamily _ = panic "isAssocFamily: no tycon?!?"
326 assocInClassErr :: Name -> SDoc
327 assocInClassErr name =
328 ptext (sLit "Associated type") <+> quotes (ppr name) <+>
329 ptext (sLit "must be inside a class instance")
331 addInsts :: [InstInfo Name] -> TcM a -> TcM a
332 addInsts infos thing_inside
333 = tcExtendLocalInstEnv (map iSpec infos) thing_inside
335 addFamInsts :: [TyThing] -> TcM a -> TcM a
336 addFamInsts tycons thing_inside
337 = tcExtendLocalFamInstEnv (map mkLocalFamInstTyThing tycons) thing_inside
339 mkLocalFamInstTyThing (ATyCon tycon) = mkLocalFamInst tycon
340 mkLocalFamInstTyThing tything = pprPanic "TcInstDcls.addFamInsts"
345 tcLocalInstDecl1 :: LInstDecl Name
346 -> TcM (InstInfo Name, [TyThing])
347 -- A source-file instance declaration
348 -- Type-check all the stuff before the "where"
350 -- We check for respectable instance type, and context
351 tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats))
353 addErrCtxt (instDeclCtxt1 poly_ty) $
355 do { is_boot <- tcIsHsBoot
356 ; checkTc (not is_boot || (isEmptyLHsBinds binds && null uprags))
359 ; (tyvars, theta, tau) <- tcHsInstHead poly_ty
361 -- Now, check the validity of the instance.
362 ; (clas, inst_tys) <- checkValidInstHead tau
363 ; checkValidInstance tyvars theta clas inst_tys
365 -- Next, process any associated types.
366 ; idx_tycons <- recoverM (return []) $
367 do { idx_tycons <- checkNoErrs $ mapAndRecoverM tcFamInstDecl ats
368 ; checkValidAndMissingATs clas (tyvars, inst_tys)
370 ; return idx_tycons }
372 -- Finally, construct the Core representation of the instance.
373 -- (This no longer includes the associated types.)
374 ; dfun_name <- newDFunName clas inst_tys (getLoc poly_ty)
375 -- Dfun location is that of instance *header*
376 ; overlap_flag <- getOverlapFlag
377 ; let (eq_theta,dict_theta) = partition isEqPred theta
378 theta' = eq_theta ++ dict_theta
379 dfun = mkDictFunId dfun_name tyvars theta' clas inst_tys
380 ispec = mkLocalInstance dfun overlap_flag
382 ; return (InstInfo { iSpec = ispec,
383 iBinds = VanillaInst binds uprags },
387 -- We pass in the source form and the type checked form of the ATs. We
388 -- really need the source form only to be able to produce more informative
390 checkValidAndMissingATs :: Class
391 -> ([TyVar], [TcType]) -- instance types
392 -> [(LTyClDecl Name, -- source form of AT
393 TyThing)] -- Core form of AT
395 checkValidAndMissingATs clas inst_tys ats
396 = do { -- Issue a warning for each class AT that is not defined in this
398 ; let class_ats = map tyConName (classATs clas)
399 defined_ats = listToNameSet . map (tcdName.unLoc.fst) $ ats
400 omitted = filterOut (`elemNameSet` defined_ats) class_ats
401 ; warn <- doptM Opt_WarnMissingMethods
402 ; mapM_ (warnTc warn . omittedATWarn) omitted
404 -- Ensure that all AT indexes that correspond to class parameters
405 -- coincide with the types in the instance head. All remaining
406 -- AT arguments must be variables. Also raise an error for any
407 -- type instances that are not associated with this class.
408 ; mapM_ (checkIndexes clas inst_tys) ats
411 checkIndexes clas inst_tys (hsAT, ATyCon tycon) =
412 -- !!!TODO: check that this does the Right Thing for indexed synonyms, too!
413 checkIndexes' clas inst_tys hsAT
415 snd . fromJust . tyConFamInst_maybe $ tycon)
416 checkIndexes _ _ _ = panic "checkIndexes"
418 checkIndexes' clas (instTvs, instTys) hsAT (atTvs, atTys)
419 = let atName = tcdName . unLoc $ hsAT
421 setSrcSpan (getLoc hsAT) $
422 addErrCtxt (atInstCtxt atName) $
423 case find ((atName ==) . tyConName) (classATs clas) of
424 Nothing -> addErrTc $ badATErr clas atName -- not in this class
426 case assocTyConArgPoss_maybe atDecl of
427 Nothing -> panic "checkIndexes': AT has no args poss?!?"
430 -- The following is tricky! We need to deal with three
431 -- complications: (1) The AT possibly only uses a subset of
432 -- the class parameters as indexes and those it uses may be in
433 -- a different order; (2) the AT may have extra arguments,
434 -- which must be type variables; and (3) variables in AT and
435 -- instance head will be different `Name's even if their
436 -- source lexemes are identical.
438 -- Re (1), `poss' contains a permutation vector to extract the
439 -- class parameters in the right order.
441 -- Re (2), we wrap the (permuted) class parameters in a Maybe
442 -- type and use Nothing for any extra AT arguments. (First
443 -- equation of `checkIndex' below.)
445 -- Re (3), we replace any type variable in the AT parameters
446 -- that has the same source lexeme as some variable in the
447 -- instance types with the instance type variable sharing its
450 let relevantInstTys = map (instTys !!) poss
451 instArgs = map Just relevantInstTys ++
452 repeat Nothing -- extra arguments
453 renaming = substSameTyVar atTvs instTvs
455 zipWithM_ checkIndex (substTys renaming atTys) instArgs
457 checkIndex ty Nothing
458 | isTyVarTy ty = return ()
459 | otherwise = addErrTc $ mustBeVarArgErr ty
460 checkIndex ty (Just instTy)
461 | ty `tcEqType` instTy = return ()
462 | otherwise = addErrTc $ wrongATArgErr ty instTy
464 listToNameSet = addListToNameSet emptyNameSet
466 substSameTyVar [] _ = emptyTvSubst
467 substSameTyVar (tv:tvs) replacingTvs =
468 let replacement = case find (tv `sameLexeme`) replacingTvs of
469 Nothing -> mkTyVarTy tv
470 Just rtv -> mkTyVarTy rtv
472 tv1 `sameLexeme` tv2 =
473 nameOccName (tyVarName tv1) == nameOccName (tyVarName tv2)
475 extendTvSubst (substSameTyVar tvs replacingTvs) tv replacement
479 %************************************************************************
481 \subsection{Type-checking instance declarations, pass 2}
483 %************************************************************************
486 tcInstDecls2 :: [LTyClDecl Name] -> [InstInfo Name]
487 -> TcM (LHsBinds Id, TcLclEnv)
488 -- (a) From each class declaration,
489 -- generate any default-method bindings
490 -- (b) From each instance decl
491 -- generate the dfun binding
493 tcInstDecls2 tycl_decls inst_decls
494 = do { -- (a) Default methods from class decls
495 (dm_binds_s, dm_ids_s) <- mapAndUnzipM tcClassDecl2 $
496 filter (isClassDecl.unLoc) tycl_decls
497 ; tcExtendIdEnv (concat dm_ids_s) $ do
499 -- (b) instance declarations
500 ; inst_binds_s <- mapM tcInstDecl2 inst_decls
503 ; let binds = unionManyBags dm_binds_s `unionBags`
504 unionManyBags inst_binds_s
505 ; tcl_env <- getLclEnv -- Default method Ids in here
506 ; return (binds, tcl_env) }
511 tcInstDecl2 :: InstInfo Name -> TcM (LHsBinds Id)
512 -- Returns a binding for the dfun
514 ------------------------
515 -- Derived newtype instances; surprisingly tricky!
517 -- class Show a => Foo a b where ...
518 -- newtype N a = MkN (Tree [a]) deriving( Foo Int )
520 -- The newtype gives an FC axiom looking like
521 -- axiom CoN a :: N a :=: Tree [a]
522 -- (see Note [Newtype coercions] in TyCon for this unusual form of axiom)
524 -- So all need is to generate a binding looking like:
525 -- dfunFooT :: forall a. (Foo Int (Tree [a], Show (N a)) => Foo Int (N a)
526 -- dfunFooT = /\a. \(ds:Show (N a)) (df:Foo (Tree [a])).
527 -- case df `cast` (Foo Int (sym (CoN a))) of
528 -- Foo _ op1 .. opn -> Foo ds op1 .. opn
530 -- If there are no superclasses, matters are simpler, because we don't need the case
531 -- see Note [Newtype deriving superclasses] in TcDeriv.lhs
533 tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = NewTypeDerived })
534 = do { let dfun_id = instanceDFunId ispec
535 rigid_info = InstSkol
536 origin = SigOrigin rigid_info
537 inst_ty = idType dfun_id
538 ; (tvs, theta, inst_head_ty) <- tcSkolSigType rigid_info inst_ty
539 -- inst_head_ty is a PredType
541 ; let (cls, cls_inst_tys) = tcSplitDFunHead inst_head_ty
542 (class_tyvars, sc_theta, _, _) = classBigSig cls
543 cls_tycon = classTyCon cls
544 sc_theta' = substTheta (zipOpenTvSubst class_tyvars cls_inst_tys) sc_theta
546 Just (initial_cls_inst_tys, last_ty) = snocView cls_inst_tys
547 (nt_tycon, tc_args) = tcSplitTyConApp last_ty -- Can't fail
548 rep_ty = newTyConInstRhs nt_tycon tc_args
550 rep_pred = mkClassPred cls (initial_cls_inst_tys ++ [rep_ty])
551 -- In our example, rep_pred is (Foo Int (Tree [a]))
552 the_coercion = make_coercion cls_tycon initial_cls_inst_tys nt_tycon tc_args
553 -- Coercion of kind (Foo Int (Tree [a]) ~ Foo Int (N a)
555 ; inst_loc <- getInstLoc origin
556 ; sc_loc <- getInstLoc InstScOrigin
557 ; dfun_dicts <- newDictBndrs inst_loc theta
558 ; sc_dicts <- newDictBndrs sc_loc sc_theta'
559 ; this_dict <- newDictBndr inst_loc (mkClassPred cls cls_inst_tys)
560 ; rep_dict <- newDictBndr inst_loc rep_pred
562 -- Figure out bindings for the superclass context from dfun_dicts
563 -- Don't include this_dict in the 'givens', else
564 -- wanted_sc_insts get bound by just selecting from this_dict!!
565 ; sc_binds <- addErrCtxt superClassCtxt $
566 tcSimplifySuperClasses inst_loc dfun_dicts (rep_dict:sc_dicts)
568 ; let coerced_rep_dict = mkHsWrap the_coercion (HsVar (instToId rep_dict))
570 ; body <- make_body cls_tycon cls_inst_tys sc_dicts coerced_rep_dict
571 ; let dict_bind = noLoc $ VarBind (instToId this_dict) (noLoc body)
573 ; return (unitBag $ noLoc $
574 AbsBinds tvs (map instToVar dfun_dicts)
575 [(tvs, dfun_id, instToId this_dict, [])]
576 (dict_bind `consBag` sc_binds)) }
578 -----------------------
580 -- The inst_head looks like (C s1 .. sm (T a1 .. ak))
581 -- But we want the coercion (C s1 .. sm (sym (CoT a1 .. ak)))
582 -- with kind (C s1 .. sm (T a1 .. ak) :=: C s1 .. sm <rep_ty>)
583 -- where rep_ty is the (eta-reduced) type rep of T
584 -- So we just replace T with CoT, and insert a 'sym'
585 -- NB: we know that k will be >= arity of CoT, because the latter fully eta-reduced
587 make_coercion cls_tycon initial_cls_inst_tys nt_tycon tc_args
588 | Just co_con <- newTyConCo_maybe nt_tycon
589 , let co = mkSymCoercion (mkTyConApp co_con tc_args)
590 = WpCast (mkTyConApp cls_tycon (initial_cls_inst_tys ++ [co]))
591 | otherwise -- The newtype is transparent; no need for a cast
594 -----------------------
595 -- (make_body C tys scs coreced_rep_dict)
597 -- (case coerced_rep_dict of { C _ ops -> C scs ops })
598 -- But if there are no superclasses, it returns just coerced_rep_dict
599 -- See Note [Newtype deriving superclasses] in TcDeriv.lhs
601 make_body cls_tycon cls_inst_tys sc_dicts coerced_rep_dict
602 | null sc_dicts -- Case (a)
603 = return coerced_rep_dict
604 | otherwise -- Case (b)
605 = do { op_ids <- newSysLocalIds (fsLit "op") op_tys
606 ; dummy_sc_dict_ids <- newSysLocalIds (fsLit "sc") (map idType sc_dict_ids)
607 ; let the_pat = ConPatOut { pat_con = noLoc cls_data_con, pat_tvs = [],
608 pat_dicts = dummy_sc_dict_ids,
609 pat_binds = emptyLHsBinds,
610 pat_args = PrefixCon (map nlVarPat op_ids),
612 the_match = mkSimpleMatch [noLoc the_pat] the_rhs
613 the_rhs = mkHsConApp cls_data_con cls_inst_tys $
614 map HsVar (sc_dict_ids ++ op_ids)
616 -- Warning: this HsCase scrutinises a value with a PredTy, which is
617 -- never otherwise seen in Haskell source code. It'd be
618 -- nicer to generate Core directly!
619 ; return (HsCase (noLoc coerced_rep_dict) $
620 MatchGroup [the_match] (mkFunTy pat_ty pat_ty)) }
622 sc_dict_ids = map instToId sc_dicts
623 pat_ty = mkTyConApp cls_tycon cls_inst_tys
624 cls_data_con = head (tyConDataCons cls_tycon)
625 cls_arg_tys = dataConInstArgTys cls_data_con cls_inst_tys
626 op_tys = dropList sc_dict_ids cls_arg_tys
628 ------------------------
629 -- Ordinary instances
631 tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags })
633 dfun_id = instanceDFunId ispec
634 rigid_info = InstSkol
635 inst_ty = idType dfun_id
636 loc = getSrcSpan dfun_id
638 -- Prime error recovery
639 recoverM (return emptyLHsBinds) $
641 addErrCtxt (instDeclCtxt2 (idType dfun_id)) $ do
643 -- Instantiate the instance decl with skolem constants
644 (inst_tyvars', dfun_theta', inst_head') <- tcSkolSigType rigid_info inst_ty
645 -- These inst_tyvars' scope over the 'where' part
646 -- Those tyvars are inside the dfun_id's type, which is a bit
647 -- bizarre, but OK so long as you realise it!
649 (clas, inst_tys') = tcSplitDFunHead inst_head'
650 (class_tyvars, sc_theta, _, op_items) = classBigSig clas
652 -- Instantiate the super-class context with inst_tys
653 sc_theta' = substTheta (zipOpenTvSubst class_tyvars inst_tys') sc_theta
654 (eq_sc_theta',dict_sc_theta') = partition isEqPred sc_theta'
655 origin = SigOrigin rigid_info
656 (eq_dfun_theta',dict_dfun_theta') = partition isEqPred dfun_theta'
658 -- Create dictionary Ids from the specified instance contexts.
659 sc_loc <- getInstLoc InstScOrigin
660 sc_dicts <- newDictBndrs sc_loc dict_sc_theta'
661 inst_loc <- getInstLoc origin
662 sc_covars <- mkMetaCoVars eq_sc_theta'
663 wanted_sc_eqs <- mkEqInsts eq_sc_theta' (map mkWantedCo sc_covars)
664 dfun_covars <- mkCoVars eq_dfun_theta'
665 dfun_eqs <- mkEqInsts eq_dfun_theta' (map mkGivenCo $ mkTyVarTys dfun_covars)
666 dfun_dicts <- newDictBndrs inst_loc dict_dfun_theta'
667 this_dict <- newDictBndr inst_loc (mkClassPred clas inst_tys')
668 -- Default-method Ids may be mentioned in synthesised RHSs,
669 -- but they'll already be in the environment.
671 -- Typecheck the methods
672 let -- These insts are in scope; quite a few, eh?
673 dfun_insts = dfun_eqs ++ dfun_dicts
674 wanted_sc_insts = wanted_sc_eqs ++ sc_dicts
675 this_dict_id = instToId this_dict
676 sc_dict_ids = map instToId sc_dicts
677 dfun_dict_ids = map instToId dfun_dicts
678 prag_fn = mkPragFun uprags
679 tc_meth = tcInstanceMethod loc clas inst_tyvars'
680 (dfun_covars ++ dfun_dict_ids)
681 dfun_theta' inst_tys'
684 (meth_exprs, meth_binds) <- mapAndUnzipM tc_meth op_items
686 -- Figure out bindings for the superclass context
687 -- Don't include this_dict in the 'givens', else
688 -- wanted_sc_insts get bound by just selecting from this_dict!!
689 sc_binds <- addErrCtxt superClassCtxt
690 (tcSimplifySuperClasses inst_loc dfun_insts wanted_sc_insts)
692 -- It's possible that the superclass stuff might unified one
693 -- of the inst_tyavars' with something in the envt
694 checkSigTyVars inst_tyvars'
696 -- Deal with 'SPECIALISE instance' pragmas
697 prags <- tcPrags dfun_id (filter isSpecInstLSig uprags)
699 -- Create the result bindings
701 dict_constr = classDataCon clas
702 inline_prag | null dfun_insts = []
703 | otherwise = [L loc (InlinePrag (Inline AlwaysActive True))]
704 -- Always inline the dfun; this is an experimental decision
705 -- because it makes a big performance difference sometimes.
706 -- Often it means we can do the method selection, and then
707 -- inline the method as well. Marcin's idea; see comments below.
709 -- BUT: don't inline it if it's a constant dictionary;
710 -- we'll get all the benefit without inlining, and we get
711 -- a **lot** of code duplication if we inline it
713 -- See Note [Inline dfuns] below
715 dict_rhs = mkHsConApp dict_constr (inst_tys' ++ mkTyVarTys sc_covars)
716 (map HsVar sc_dict_ids ++ meth_exprs)
717 -- We don't produce a binding for the dict_constr; instead we
718 -- rely on the simplifier to unfold this saturated application
719 -- We do this rather than generate an HsCon directly, because
720 -- it means that the special cases (e.g. dictionary with only one
721 -- member) are dealt with by the common MkId.mkDataConWrapId code rather
722 -- than needing to be repeated here.
724 dict_bind = noLoc (VarBind this_dict_id dict_rhs)
726 main_bind = noLoc $ AbsBinds
727 (inst_tyvars' ++ dfun_covars)
729 [(inst_tyvars' ++ dfun_covars, dfun_id, this_dict_id, inline_prag ++ prags)]
730 (dict_bind `consBag` sc_binds)
732 showLIE (text "instance")
733 return (main_bind `consBag` unionManyBags meth_binds)
735 mkCoVars :: [PredType] -> TcM [TyVar]
736 mkCoVars = newCoVars . map unEqPred
738 unEqPred (EqPred ty1 ty2) = (ty1, ty2)
739 unEqPred _ = panic "TcInstDcls.mkCoVars"
741 mkMetaCoVars :: [PredType] -> TcM [TyVar]
742 mkMetaCoVars = mapM eqPredToCoVar
744 eqPredToCoVar (EqPred ty1 ty2) = newMetaCoVar ty1 ty2
745 eqPredToCoVar _ = panic "TcInstDcls.mkMetaCoVars"
751 - Make the method bindings, as a [(NonRec, HsBinds)], one per method
752 - Remembering to use fresh Name (the instance method Name) as the binder
753 - Bring the instance method Ids into scope, for the benefit of tcInstSig
754 - Use sig_fn mapping instance method Name -> instance tyvars
756 - Use tcValBinds to do the checking
759 tcInstanceMethod :: SrcSpan -> Class -> [TcTyVar] -> [Var]
760 -> TcThetaType -> [TcType] -> Id
761 -> LHsBinds Name -> TcPragFun
763 -> TcM (HsExpr Id, LHsBinds Id)
764 -- The returned inst_meth_ids all have types starting
765 -- forall tvs. theta => ...
767 tcInstanceMethod loc clas tyvars dfun_lam_vars theta inst_tys this_dict_id
768 binds_in prag_fn (sel_id, dm_info)
769 = do { uniq <- newUnique
770 ; let (sel_tyvars,sel_rho) = tcSplitForAllTys (idType sel_id)
771 rho_ty = ASSERT( length sel_tyvars == length inst_tys )
772 substTyWith sel_tyvars inst_tys sel_rho
773 (first_pred, meth_tau) = tcSplitPredFunTy_maybe rho_ty
774 `orElse` pprPanic "tcInstanceMethod" (ppr sel_id)
776 -- The first predicate should be of form (C a b)
777 -- where C is the class in question
778 meth_ty = mkSigmaTy tyvars theta meth_tau
779 meth_name = mkInternalName uniq sel_occ loc -- Same OccName
780 meth_id = mkLocalId meth_name meth_ty
782 ; MASSERT( case getClassPredTys_maybe first_pred of
783 { Just (clas1, _tys) -> clas == clas1 ; Nothing -> False } )
786 ; case (findMethodBind sel_name meth_name binds_in, dm_info) of
787 -- There is a user-supplied method binding, so use it
788 (Just user_bind, _) -> typecheck_meth meth_id user_bind
790 -- The user didn't supply a method binding, so we have to make
791 -- up a default binding, in a way depending on the default-method info
793 (Nothing, GenDefMeth) -> do -- Derivable type classes stuff
794 { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id meth_name
795 ; typecheck_meth meth_id meth_bind }
797 (Nothing, NoDefMeth) -> do -- No default method in the class
798 { warn <- doptM Opt_WarnMissingMethods
799 ; warnTc (warn -- Warn only if -fwarn-missing-methods
800 && reportIfUnused (getOccName sel_id))
801 -- Don't warn about _foo methods
802 (omittedMethodWarn sel_id)
803 ; return (mk_error_rhs meth_tau, emptyBag) }
805 (Nothing, DefMeth) -> do -- An polymorphic default method
806 { -- Build the typechecked version directly,
807 -- without calling typecheck_method;
808 -- see Note [Default methods in instances]
809 dm_name <- lookupImportedName (mkDefMethRdrName sel_name)
810 -- Might not be imported, but will be an OrigName
811 ; dm_id <- tcLookupId dm_name
812 ; return (wrap dm_wrapper dm_id, emptyBag) } }
814 sel_name = idName sel_id
815 sel_occ = nameOccName sel_name
816 tv_names = map tyVarName tyvars
817 prags = prag_fn sel_name
819 typecheck_meth :: Id -> LHsBind Name -> TcM (HsExpr Id, LHsBinds Id)
820 typecheck_meth meth_id bind
821 = do { tc_binds <- tcMethodBind tv_names prags meth_id bind
822 ; return (wrap meth_wrapper meth_id, tc_binds) }
824 mk_error_rhs tau = HsApp (mkLHsWrap (WpTyApp tau) error_id) error_msg
825 error_id = L loc (HsVar nO_METHOD_BINDING_ERROR_ID)
826 error_msg = L loc (HsLit (HsStringPrim (mkFastString error_string)))
827 error_string = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
829 wrap wrapper id = mkHsWrap wrapper (HsVar id)
830 meth_wrapper = mkWpApps dfun_lam_vars `WpCompose` mkWpTyApps (mkTyVarTys tyvars)
831 dm_wrapper = WpApp this_dict_id `WpCompose` mkWpTyApps inst_tys
833 omittedMethodWarn :: Id -> SDoc
834 omittedMethodWarn sel_id
835 = ptext (sLit "No explicit method nor default method for") <+> quotes (ppr sel_id)
838 Note [Default methods in instances]
839 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
848 From the class decl we get
850 $dmfoo :: forall v x. Baz v x => x -> x
852 Notice that the type is ambiguous. That's fine, though. The instance decl generates
854 $dBazIntInt = MkBaz ($dmfoo Int Int $dBazIntInt)
856 BUT this does mean we must generate the dictionary translation directly, rather
857 than generating source-code and type-checking it. That was the bug ing
858 Trac #1061. In any case it's less work to generate the translated version!
861 %************************************************************************
863 \subsection{Error messages}
865 %************************************************************************
868 instDeclCtxt1 :: LHsType Name -> SDoc
869 instDeclCtxt1 hs_inst_ty
870 = inst_decl_ctxt (case unLoc hs_inst_ty of
871 HsForAllTy _ _ _ (L _ (HsPredTy pred)) -> ppr pred
872 HsPredTy pred -> ppr pred
873 _ -> ppr hs_inst_ty) -- Don't expect this
874 instDeclCtxt2 :: Type -> SDoc
875 instDeclCtxt2 dfun_ty
876 = inst_decl_ctxt (ppr (mkClassPred cls tys))
878 (_,_,cls,tys) = tcSplitDFunTy dfun_ty
880 inst_decl_ctxt :: SDoc -> SDoc
881 inst_decl_ctxt doc = ptext (sLit "In the instance declaration for") <+> quotes doc
883 superClassCtxt :: SDoc
884 superClassCtxt = ptext (sLit "When checking the super-classes of an instance declaration")
886 atInstCtxt :: Name -> SDoc
887 atInstCtxt name = ptext (sLit "In the associated type instance for") <+>
890 mustBeVarArgErr :: Type -> SDoc
892 sep [ ptext (sLit "Arguments that do not correspond to a class parameter") <+>
893 ptext (sLit "must be variables")
894 , ptext (sLit "Instead of a variable, found") <+> ppr ty
897 wrongATArgErr :: Type -> Type -> SDoc
898 wrongATArgErr ty instTy =
899 sep [ ptext (sLit "Type indexes must match class instance head")
900 , ptext (sLit "Found") <+> ppr ty <+> ptext (sLit "but expected") <+>