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
15 import TcPat( addInlinePrags )
26 import RnSource ( addTcgDUs )
29 import MkCore ( nO_METHOD_BINDING_ERROR_ID )
38 import CoreUtils ( mkPiTypes )
39 import CoreUnfold ( mkDFunUnfolding )
40 import CoreSyn ( Expr(Var), DFunArg(..), CoreExpr )
53 import Maybes ( orElse )
58 #include "HsVersions.h"
61 Typechecking instance declarations is done in two passes. The first
62 pass, made by @tcInstDecls1@, collects information to be used in the
65 This pre-processed info includes the as-yet-unprocessed bindings
66 inside the instance declaration. These are type-checked in the second
67 pass, when the class-instance envs and GVE contain all the info from
68 all the instance and value decls. Indeed that's the reason we need
69 two passes over the instance decls.
72 Note [How instance declarations are translated]
73 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
74 Here is how we translation instance declarations into Core
78 op1, op2 :: Ix b => a -> b -> b
82 {-# INLINE [2] op1 #-}
86 op1,op2 :: forall a. C a => forall b. Ix b => a -> b -> b
90 -- Default methods get the 'self' dictionary as argument
91 -- so they can call other methods at the same type
92 -- Default methods get the same type as their method selector
93 $dmop2 :: forall a. C a => forall b. Ix b => a -> b -> b
94 $dmop2 = /\a. \(d:C a). /\b. \(d2: Ix b). <dm-rhs>
95 -- NB: type variables 'a' and 'b' are *both* in scope in <dm-rhs>
96 -- Note [Tricky type variable scoping]
98 -- A top-level definition for each instance method
99 -- Here op1_i, op2_i are the "instance method Ids"
100 -- The INLINE pragma comes from the user pragma
101 {-# INLINE [2] op1_i #-} -- From the instance decl bindings
102 op1_i, op2_i :: forall a. C a => forall b. Ix b => [a] -> b -> b
103 op1_i = /\a. \(d:C a).
106 -- Note [Subtle interaction of recursion and overlap]
108 local_op1 :: forall b. Ix b => [a] -> b -> b
110 -- Source code; run the type checker on this
111 -- NB: Type variable 'a' (but not 'b') is in scope in <rhs>
112 -- Note [Tricky type variable scoping]
116 op2_i = /\a \d:C a. $dmop2 [a] (df_i a d)
118 -- The dictionary function itself
119 {-# NOINLINE CONLIKE df_i #-} -- Never inline dictionary functions
120 df_i :: forall a. C a -> C [a]
121 df_i = /\a. \d:C a. MkC (op1_i a d) (op2_i a d)
122 -- But see Note [Default methods in instances]
123 -- We can't apply the type checker to the default-method call
125 -- Use a RULE to short-circuit applications of the class ops
126 {-# RULE "op1@C[a]" forall a, d:C a.
127 op1 [a] (df_i d) = op1_i a d #-}
129 Note [Instances and loop breakers]
130 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
131 * Note that df_i may be mutually recursive with both op1_i and op2_i.
132 It's crucial that df_i is not chosen as the loop breaker, even
133 though op1_i has a (user-specified) INLINE pragma.
135 * Instead the idea is to inline df_i into op1_i, which may then select
136 methods from the MkC record, and thereby break the recursion with
137 df_i, leaving a *self*-recurisve op1_i. (If op1_i doesn't call op at
138 the same type, it won't mention df_i, so there won't be recursion in
141 * If op1_i is marked INLINE by the user there's a danger that we won't
142 inline df_i in it, and that in turn means that (since it'll be a
143 loop-breaker because df_i isn't), op1_i will ironically never be
144 inlined. But this is OK: the recursion breaking happens by way of
145 a RULE (the magic ClassOp rule above), and RULES work inside InlineRule
146 unfoldings. See Note [RULEs enabled in SimplGently] in SimplUtils
148 Note [ClassOp/DFun selection]
149 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
150 One thing we see a lot is stuff like
152 where 'op2' is a ClassOp and 'df' is DFun. Now, we could inline *both*
153 'op2' and 'df' to get
154 case (MkD ($cop1 d1 d2) ($cop2 d1 d2) ... of
155 MkD _ op2 _ _ _ -> op2
156 And that will reduce to ($cop2 d1 d2) which is what we wanted.
158 But it's tricky to make this work in practice, because it requires us to
159 inline both 'op2' and 'df'. But neither is keen to inline without having
160 seen the other's result; and it's very easy to get code bloat (from the
161 big intermediate) if you inline a bit too much.
163 Instead we use a cunning trick.
164 * We arrange that 'df' and 'op2' NEVER inline.
166 * We arrange that 'df' is ALWAYS defined in the sylised form
167 df d1 d2 = MkD ($cop1 d1 d2) ($cop2 d1 d2) ...
169 * We give 'df' a magical unfolding (DFunUnfolding [$cop1, $cop2, ..])
170 that lists its methods.
172 * We make CoreUnfold.exprIsConApp_maybe spot a DFunUnfolding and return
173 a suitable constructor application -- inlining df "on the fly" as it
176 * We give the ClassOp 'op2' a BuiltinRule that extracts the right piece
177 iff its argument satisfies exprIsConApp_maybe. This is done in
180 * We make 'df' CONLIKE, so that shared uses stil match; eg
182 in ...(op2 d)...(op1 d)...
184 Note [Single-method classes]
185 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
186 If the class has just one method (or, more accurately, just one element
187 of {superclasses + methods}), then we use a different strategy.
189 class C a where op :: a -> a
190 instance C a => C [a] where op = <blah>
192 We translate the class decl into a newtype, which just gives a
193 top-level axiom. The "constructor" MkC expands to a cast, as does the
196 axiom Co:C a :: C a ~ (a->a)
198 op :: forall a. C a -> (a -> a)
199 op a d = d |> (Co:C a)
201 MkC :: forall a. (a->a) -> C a
202 MkC = /\a.\op. op |> (sym Co:C a)
204 The clever RULE stuff doesn't work now, because ($df a d) isn't
205 a constructor application, so exprIsConApp_maybe won't return
208 Instead, we simply rely on the fact that casts are cheap:
210 $df :: forall a. C a => C [a]
211 {-# INLINE df #-} -- NB: INLINE this
212 $df = /\a. \d. MkC [a] ($cop_list a d)
213 = $cop_list |> forall a. C a -> (sym (Co:C [a]))
215 $cop_list :: forall a. C a => [a] -> [a]
220 we'll inline 'op' and '$df', since both are simply casts, and
223 Why do we use this different strategy? Because otherwise we
224 end up with non-inlined dictionaries that look like
226 which adds an extra indirection to every use, which seems stupid. See
227 Trac #4138 for an example (although the regression reported there
228 wasn't due to the indirction).
230 There is an awkward wrinkle though: we want to be very
232 instance C a => C [a] where
235 then we'll get an INLINE pragma on $cop_list but it's important that
236 $cop_list only inlines when it's applied to *two* arguments (the
237 dictionary and the list argument). So we nust not eta-expand $df
238 above. We ensure that this doesn't happen by putting an INLINE
239 pragma on the dfun itself; after all, it ends up being just a cast.
241 There is one more dark corner to the INLINE story, even more deeply
242 buried. Consider this (Trac #3772):
244 class DeepSeq a => C a where
247 instance C a => C [a] where
250 class DeepSeq a where
251 deepSeq :: a -> b -> b
253 instance DeepSeq a => DeepSeq [a] where
254 {-# INLINE deepSeq #-}
255 deepSeq xs b = foldr deepSeq b xs
257 That gives rise to these defns:
259 $cdeepSeq :: DeepSeq a -> [a] -> b -> b
260 -- User INLINE( 3 args )!
261 $cdeepSeq a (d:DS a) b (x:[a]) (y:b) = ...
263 $fDeepSeq[] :: DeepSeq a -> DeepSeq [a]
264 -- DFun (with auto INLINE pragma)
265 $fDeepSeq[] a d = $cdeepSeq a d |> blah
267 $cp1 a d :: C a => DeepSep [a]
268 -- We don't want to eta-expand this, lest
269 -- $cdeepSeq gets inlined in it!
270 $cp1 a d = $fDeepSep[] a (scsel a d)
272 $fC[] :: C a => C [a]
274 $fC[] a d = MkC ($cp1 a d) ($cgen a d)
276 Here $cp1 is the code that generates the superclass for C [a]. The
277 issue is this: we must not eta-expand $cp1 either, or else $fDeepSeq[]
278 and then $cdeepSeq will inline there, which is definitely wrong. Like
279 on the dfun, we solve this by adding an INLINE pragma to $cp1.
281 Note [Subtle interaction of recursion and overlap]
282 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
284 class C a where { op1,op2 :: a -> a }
285 instance C a => C [a] where
286 op1 x = op2 x ++ op2 x
288 instance C [Int] where
291 When type-checking the C [a] instance, we need a C [a] dictionary (for
292 the call of op2). If we look up in the instance environment, we find
293 an overlap. And in *general* the right thing is to complain (see Note
294 [Overlapping instances] in InstEnv). But in *this* case it's wrong to
295 complain, because we just want to delegate to the op2 of this same
298 Why is this justified? Because we generate a (C [a]) constraint in
299 a context in which 'a' cannot be instantiated to anything that matches
300 other overlapping instances, or else we would not be excecuting this
301 version of op1 in the first place.
303 It might even be a bit disguised:
305 nullFail :: C [a] => [a] -> [a]
306 nullFail x = op2 x ++ op2 x
308 instance C a => C [a] where
311 Precisely this is used in package 'regex-base', module Context.hs.
312 See the overlapping instances for RegexContext, and the fact that they
313 call 'nullFail' just like the example above. The DoCon package also
314 does the same thing; it shows up in module Fraction.hs
316 Conclusion: when typechecking the methods in a C [a] instance, we want to
317 treat the 'a' as an *existential* type variable, in the sense described
318 by Note [Binding when looking up instances]. That is why isOverlappableTyVar
319 responds True to an InstSkol, which is the kind of skolem we use in
323 Note [Tricky type variable scoping]
324 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
327 op1, op2 :: Ix b => a -> b -> b
330 instance C a => C [a]
331 {-# INLINE [2] op1 #-}
334 note that 'a' and 'b' are *both* in scope in <dm-rhs>, but only 'a' is
335 in scope in <rhs>. In particular, we must make sure that 'b' is in
336 scope when typechecking <dm-rhs>. This is achieved by subFunTys,
337 which brings appropriate tyvars into scope. This happens for both
338 <dm-rhs> and for <rhs>, but that doesn't matter: the *renamer* will have
339 complained if 'b' is mentioned in <rhs>.
343 %************************************************************************
345 \subsection{Extracting instance decls}
347 %************************************************************************
349 Gather up the instance declarations from their various sources
352 tcInstDecls1 -- Deal with both source-code and imported instance decls
353 :: [LTyClDecl Name] -- For deriving stuff
354 -> [LInstDecl Name] -- Source code instance decls
355 -> [LDerivDecl Name] -- Source code stand-alone deriving decls
356 -> TcM (TcGblEnv, -- The full inst env
357 [InstInfo Name], -- Source-code instance decls to process;
358 -- contains all dfuns for this module
359 HsValBinds Name) -- Supporting bindings for derived instances
361 tcInstDecls1 tycl_decls inst_decls deriv_decls
363 do { -- Stop if addInstInfos etc discovers any errors
364 -- (they recover, so that we get more than one error each
367 -- (1) Do class and family instance declarations
368 ; idx_tycons <- mapAndRecoverM (tcFamInstDecl TopLevel) $
369 filter (isFamInstDecl . unLoc) tycl_decls
370 ; local_info_tycons <- mapAndRecoverM tcLocalInstDecl1 inst_decls
373 at_tycons_s) = unzip local_info_tycons
374 ; at_idx_tycons = concat at_tycons_s ++ idx_tycons
375 ; implicit_things = concatMap implicitTyThings at_idx_tycons
376 ; aux_binds = mkRecSelBinds at_idx_tycons
379 -- (2) Add the tycons of indexed types and their implicit
380 -- tythings to the global environment
381 ; tcExtendGlobalEnv (at_idx_tycons ++ implicit_things) $ do {
384 -- Next, construct the instance environment so far, consisting
386 -- (a) local instance decls
387 -- (b) local family instance decls
388 ; addInsts local_info $
389 addFamInsts at_idx_tycons $ do {
391 -- (3) Compute instances from "deriving" clauses;
392 -- This stuff computes a context for the derived instance
393 -- decl, so it needs to know about all the instances possible
394 -- NB: class instance declarations can contain derivings as
395 -- part of associated data type declarations
396 failIfErrsM -- If the addInsts stuff gave any errors, don't
397 -- try the deriving stuff, because that may give
399 ; (deriv_inst_info, deriv_binds, deriv_dus, deriv_tys, deriv_ty_insts)
400 <- tcDeriving tycl_decls inst_decls deriv_decls
402 -- Extend the global environment also with the generated datatypes for
403 -- the generic representation
404 ; gbl_env <- addFamInsts (map ATyCon deriv_ty_insts) $
405 tcExtendGlobalEnv (map ATyCon (deriv_tys ++ deriv_ty_insts)) $
406 addInsts deriv_inst_info getGblEnv
407 ; return ( addTcgDUs gbl_env deriv_dus,
408 deriv_inst_info ++ local_info,
409 aux_binds `plusHsValBinds` deriv_binds)
412 addInsts :: [InstInfo Name] -> TcM a -> TcM a
413 addInsts infos thing_inside
414 = tcExtendLocalInstEnv (map iSpec infos) thing_inside
416 addFamInsts :: [TyThing] -> TcM a -> TcM a
417 addFamInsts tycons thing_inside
418 = tcExtendLocalFamInstEnv (map mkLocalFamInstTyThing tycons) thing_inside
420 mkLocalFamInstTyThing (ATyCon tycon) = mkLocalFamInst tycon
421 mkLocalFamInstTyThing tything = pprPanic "TcInstDcls.addFamInsts"
426 tcLocalInstDecl1 :: LInstDecl Name
427 -> TcM (InstInfo Name, [TyThing])
428 -- A source-file instance declaration
429 -- Type-check all the stuff before the "where"
431 -- We check for respectable instance type, and context
432 tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats))
434 addErrCtxt (instDeclCtxt1 poly_ty) $
436 do { is_boot <- tcIsHsBoot
437 ; checkTc (not is_boot || (isEmptyLHsBinds binds && null uprags))
440 ; (tyvars, theta, clas, inst_tys) <- tcHsInstHead poly_ty
441 ; checkValidInstance poly_ty tyvars theta clas inst_tys
443 -- Next, process any associated types.
444 ; idx_tycons <- recoverM (return []) $
445 do { idx_tycons <- checkNoErrs $
446 mapAndRecoverM (tcFamInstDecl NotTopLevel) ats
447 ; checkValidAndMissingATs clas (tyvars, inst_tys)
449 ; return idx_tycons }
451 -- Finally, construct the Core representation of the instance.
452 -- (This no longer includes the associated types.)
453 ; dfun_name <- newDFunName clas inst_tys (getLoc poly_ty)
454 -- Dfun location is that of instance *header*
455 ; overlap_flag <- getOverlapFlag
456 ; let (eq_theta,dict_theta) = partition isEqPred theta
457 theta' = eq_theta ++ dict_theta
458 dfun = mkDictFunId dfun_name tyvars theta' clas inst_tys
459 ispec = mkLocalInstance dfun overlap_flag
461 ; return (InstInfo { iSpec = ispec, iBinds = VanillaInst binds uprags False },
465 -- We pass in the source form and the type checked form of the ATs. We
466 -- really need the source form only to be able to produce more informative
468 checkValidAndMissingATs :: Class
469 -> ([TyVar], [TcType]) -- instance types
470 -> [(LTyClDecl Name, -- source form of AT
471 TyThing)] -- Core form of AT
473 checkValidAndMissingATs clas inst_tys ats
474 = do { -- Issue a warning for each class AT that is not defined in this
476 ; let class_ats = map tyConName (classATs clas)
477 defined_ats = listToNameSet . map (tcdName.unLoc.fst) $ ats
478 omitted = filterOut (`elemNameSet` defined_ats) class_ats
479 ; warn <- doptM Opt_WarnMissingMethods
480 ; mapM_ (warnTc warn . omittedATWarn) omitted
482 -- Ensure that all AT indexes that correspond to class parameters
483 -- coincide with the types in the instance head. All remaining
484 -- AT arguments must be variables. Also raise an error for any
485 -- type instances that are not associated with this class.
486 ; mapM_ (checkIndexes clas inst_tys) ats
489 checkIndexes clas inst_tys (hsAT, ATyCon tycon)
490 -- !!!TODO: check that this does the Right Thing for indexed synonyms, too!
491 = checkIndexes' clas inst_tys hsAT
493 snd . fromJust . tyConFamInst_maybe $ tycon)
494 checkIndexes _ _ _ = panic "checkIndexes"
496 checkIndexes' clas (instTvs, instTys) hsAT (atTvs, atTys)
497 = let atName = tcdName . unLoc $ hsAT
499 setSrcSpan (getLoc hsAT) $
500 addErrCtxt (atInstCtxt atName) $
501 case find ((atName ==) . tyConName) (classATs clas) of
502 Nothing -> addErrTc $ badATErr clas atName -- not in this class
504 -- The following is tricky! We need to deal with three
505 -- complications: (1) The AT possibly only uses a subset of
506 -- the class parameters as indexes and those it uses may be in
507 -- a different order; (2) the AT may have extra arguments,
508 -- which must be type variables; and (3) variables in AT and
509 -- instance head will be different `Name's even if their
510 -- source lexemes are identical.
512 -- e.g. class C a b c where
513 -- data D b a :: * -> * -- NB (1) b a, omits c
514 -- instance C [x] Bool Char where
515 -- data D Bool [x] v = MkD x [v] -- NB (2) v
516 -- -- NB (3) the x in 'instance C...' have differnt
517 -- -- Names to x's in 'data D...'
519 -- Re (1), `poss' contains a permutation vector to extract the
520 -- class parameters in the right order.
522 -- Re (2), we wrap the (permuted) class parameters in a Maybe
523 -- type and use Nothing for any extra AT arguments. (First
524 -- equation of `checkIndex' below.)
526 -- Re (3), we replace any type variable in the AT parameters
527 -- that has the same source lexeme as some variable in the
528 -- instance types with the instance type variable sharing its
532 -- For *associated* type families, gives the position
533 -- of that 'TyVar' in the class argument list (0-indexed)
534 -- e.g. class C a b c where { type F c a :: *->* }
535 -- Then we get Just [2,0]
536 poss = catMaybes [ tv `elemIndex` classTyVars clas
537 | tv <- tyConTyVars atycon]
538 -- We will get Nothings for the "extra" type
539 -- variables in an associated data type
540 -- e.g. class C a where { data D a :: *->* }
541 -- here D gets arity 2 and has two tyvars
543 relevantInstTys = map (instTys !!) poss
544 instArgs = map Just relevantInstTys ++
545 repeat Nothing -- extra arguments
546 renaming = substSameTyVar atTvs instTvs
548 zipWithM_ checkIndex (substTys renaming atTys) instArgs
550 checkIndex ty Nothing
551 | isTyVarTy ty = return ()
552 | otherwise = addErrTc $ mustBeVarArgErr ty
553 checkIndex ty (Just instTy)
554 | ty `eqType` instTy = return ()
555 | otherwise = addErrTc $ wrongATArgErr ty instTy
557 listToNameSet = addListToNameSet emptyNameSet
559 substSameTyVar [] _ = emptyTvSubst
560 substSameTyVar (tv:tvs) replacingTvs =
561 let replacement = case find (tv `sameLexeme`) replacingTvs of
562 Nothing -> mkTyVarTy tv
563 Just rtv -> mkTyVarTy rtv
565 tv1 `sameLexeme` tv2 =
566 nameOccName (tyVarName tv1) == nameOccName (tyVarName tv2)
568 TcType.extendTvSubst (substSameTyVar tvs replacingTvs) tv replacement
572 %************************************************************************
574 Type checking family instances
576 %************************************************************************
578 Family instances are somewhat of a hybrid. They are processed together with
579 class instance heads, but can contain data constructors and hence they share a
580 lot of kinding and type checking code with ordinary algebraic data types (and
584 tcFamInstDecl :: TopLevelFlag -> LTyClDecl Name -> TcM TyThing
585 tcFamInstDecl top_lvl (L loc decl)
586 = -- Prime error recovery, set source location
589 do { -- type family instances require -XTypeFamilies
590 -- and can't (currently) be in an hs-boot file
591 ; type_families <- xoptM Opt_TypeFamilies
592 ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file?
593 ; checkTc type_families $ badFamInstDecl (tcdLName decl)
594 ; checkTc (not is_boot) $ badBootFamInstDeclErr
596 -- Perform kind and type checking
597 ; tc <- tcFamInstDecl1 decl
598 ; checkValidTyCon tc -- Remember to check validity;
599 -- no recursion to worry about here
601 -- Check that toplevel type instances are not for associated types.
602 ; when (isTopLevel top_lvl && isAssocFamily tc)
603 (addErr $ assocInClassErr (tcdName decl))
605 ; return (ATyCon tc) }
607 isAssocFamily :: TyCon -> Bool -- Is an assocaited type
609 = case tyConFamInst_maybe tycon of
610 Nothing -> panic "isAssocFamily: no family?!?"
611 Just (fam, _) -> isTyConAssoc fam
613 assocInClassErr :: Name -> SDoc
615 = ptext (sLit "Associated type") <+> quotes (ppr name) <+>
616 ptext (sLit "must be inside a class instance")
620 tcFamInstDecl1 :: TyClDecl Name -> TcM TyCon
623 tcFamInstDecl1 (decl@TySynonym {tcdLName = L loc tc_name})
624 = kcIdxTyPats decl $ \k_tvs k_typats resKind family ->
625 do { -- check that the family declaration is for a synonym
626 checkTc (isFamilyTyCon family) (notFamily family)
627 ; checkTc (isSynTyCon family) (wrongKindOfFamily family)
629 ; -- (1) kind check the right-hand side of the type equation
630 ; k_rhs <- kcCheckLHsType (tcdSynRhs decl) (EK resKind EkUnk)
631 -- ToDo: the ExpKind could be better
633 -- we need the exact same number of type parameters as the family
635 ; let famArity = tyConArity family
636 ; checkTc (length k_typats == famArity) $
637 wrongNumberOfParmsErr famArity
639 -- (2) type check type equation
640 ; tcTyVarBndrs k_tvs $ \t_tvs -> do { -- turn kinded into proper tyvars
641 ; t_typats <- mapM tcHsKindedType k_typats
642 ; t_rhs <- tcHsKindedType k_rhs
644 -- (3) check the well-formedness of the instance
645 ; checkValidTypeInst t_typats t_rhs
647 -- (4) construct representation tycon
648 ; rep_tc_name <- newFamInstTyConName tc_name t_typats loc
649 ; buildSynTyCon rep_tc_name t_tvs (SynonymTyCon t_rhs)
651 NoParentTyCon (Just (family, t_typats))
654 -- "newtype instance" and "data instance"
655 tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
657 = kcIdxTyPats decl $ \k_tvs k_typats resKind fam_tycon ->
658 do { -- check that the family declaration is for the right kind
659 checkTc (isFamilyTyCon fam_tycon) (notFamily fam_tycon)
660 ; checkTc (isAlgTyCon fam_tycon) (wrongKindOfFamily fam_tycon)
662 ; -- (1) kind check the data declaration as usual
663 ; k_decl <- kcDataDecl decl k_tvs
664 ; let k_ctxt = tcdCtxt k_decl
665 k_cons = tcdCons k_decl
667 -- result kind must be '*' (otherwise, we have too few patterns)
668 ; checkTc (isLiftedTypeKind resKind) $ tooFewParmsErr (tyConArity fam_tycon)
670 -- (2) type check indexed data type declaration
671 ; tcTyVarBndrs k_tvs $ \t_tvs -> do { -- turn kinded into proper tyvars
672 ; unbox_strict <- doptM Opt_UnboxStrictFields
674 -- kind check the type indexes and the context
675 ; t_typats <- mapM tcHsKindedType k_typats
676 ; stupid_theta <- tcHsKindedContext k_ctxt
679 -- (a) left-hand side contains no type family applications
680 -- (vanilla synonyms are fine, though, and we checked for
682 ; mapM_ checkTyFamFreeness t_typats
684 ; dataDeclChecks tc_name new_or_data stupid_theta k_cons
686 -- (4) construct representation tycon
687 ; rep_tc_name <- newFamInstTyConName tc_name t_typats loc
688 ; let ex_ok = True -- Existentials ok for type families!
689 ; fixM (\ rep_tycon -> do
690 { let orig_res_ty = mkTyConApp fam_tycon t_typats
691 ; data_cons <- tcConDecls unbox_strict ex_ok rep_tycon
692 (t_tvs, orig_res_ty) k_cons
695 DataType -> return (mkDataTyConRhs data_cons)
696 NewType -> ASSERT( not (null data_cons) )
697 mkNewTyConRhs rep_tc_name rep_tycon (head data_cons)
698 ; buildAlgTyCon rep_tc_name t_tvs stupid_theta tc_rhs Recursive
699 False h98_syntax NoParentTyCon (Just (fam_tycon, t_typats))
700 -- We always assume that indexed types are recursive. Why?
701 -- (1) Due to their open nature, we can never be sure that a
702 -- further instance might not introduce a new recursive
703 -- dependency. (2) They are always valid loop breakers as
704 -- they involve a coercion.
708 h98_syntax = case cons of -- All constructors have same shape
709 L _ (ConDecl { con_res = ResTyGADT _ }) : _ -> False
712 tcFamInstDecl1 d = pprPanic "tcFamInstDecl1" (ppr d)
714 -- Kind checking of indexed types
717 -- Kind check type patterns and kind annotate the embedded type variables.
719 -- * Here we check that a type instance matches its kind signature, but we do
720 -- not check whether there is a pattern for each type index; the latter
721 -- check is only required for type synonym instances.
723 kcIdxTyPats :: TyClDecl Name
724 -> ([LHsTyVarBndr Name] -> [LHsType Name] -> Kind -> TyCon -> TcM a)
725 -- ^^kinded tvs ^^kinded ty pats ^^res kind
727 kcIdxTyPats decl thing_inside
728 = kcHsTyVars (tcdTyVars decl) $ \tvs ->
729 do { let tc_name = tcdLName decl
730 ; fam_tycon <- tcLookupLocatedTyCon tc_name
731 ; let { (kinds, resKind) = splitKindFunTys (tyConKind fam_tycon)
732 ; hs_typats = fromJust $ tcdTyPats decl }
734 -- we may not have more parameters than the kind indicates
735 ; checkTc (length kinds >= length hs_typats) $
736 tooManyParmsErr (tcdLName decl)
738 -- type functions can have a higher-kinded result
739 ; let resultKind = mkArrowKinds (drop (length hs_typats) kinds) resKind
740 ; typats <- zipWithM kcCheckLHsType hs_typats
741 [ EK kind (EkArg (ppr tc_name) n)
742 | (kind,n) <- kinds `zip` [1..]]
743 ; thing_inside tvs typats resultKind fam_tycon
748 %************************************************************************
750 Type-checking instance declarations, pass 2
752 %************************************************************************
755 tcInstDecls2 :: [LTyClDecl Name] -> [InstInfo Name]
757 -- (a) From each class declaration,
758 -- generate any default-method bindings
759 -- (b) From each instance decl
760 -- generate the dfun binding
762 tcInstDecls2 tycl_decls inst_decls
763 = do { -- (a) Default methods from class decls
764 let class_decls = filter (isClassDecl . unLoc) tycl_decls
765 ; dm_binds_s <- mapM tcClassDecl2 class_decls
766 ; let dm_binds = unionManyBags dm_binds_s
768 -- (b) instance declarations
769 ; let dm_ids = collectHsBindsBinders dm_binds
770 -- Add the default method Ids (again)
771 -- See Note [Default methods and instances]
772 ; inst_binds_s <- tcExtendIdEnv dm_ids $
773 mapM tcInstDecl2 inst_decls
776 ; return (dm_binds `unionBags` unionManyBags inst_binds_s) }
779 See Note [Default methods and instances]
780 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
781 The default method Ids are already in the type environment (see Note
782 [Default method Ids and Template Haskell] in TcTyClsDcls), BUT they
783 don't have their InlinePragmas yet. Usually that would not matter,
784 because the simplifier propagates information from binding site to
785 use. But, unusually, when compiling instance decls we *copy* the
786 INLINE pragma from the default method to the method for that
787 particular operation (see Note [INLINE and default methods] below).
789 So right here in tcInstDecl2 we must re-extend the type envt with
790 the default method Ids replete with their INLINE pragmas. Urk.
794 tcInstDecl2 :: InstInfo Name -> TcM (LHsBinds Id)
795 -- Returns a binding for the dfun
796 tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
797 = recoverM (return emptyLHsBinds) $
799 addErrCtxt (instDeclCtxt2 (idType dfun_id)) $
800 do { -- Instantiate the instance decl with skolem constants
801 ; (inst_tyvars, dfun_theta, inst_head) <- tcSkolDFunType (idType dfun_id)
802 ; let (clas, inst_tys) = tcSplitDFunHead inst_head
803 (class_tyvars, sc_theta, _, op_items) = classBigSig clas
804 sc_theta' = substTheta (zipOpenTvSubst class_tyvars inst_tys) sc_theta
805 n_ty_args = length inst_tyvars
806 n_silent = dfunNSilent dfun_id
807 (silent_theta, orig_theta) = splitAt n_silent dfun_theta
809 ; silent_ev_vars <- mapM newSilentGiven silent_theta
810 ; orig_ev_vars <- newEvVars orig_theta
811 ; let dfun_ev_vars = silent_ev_vars ++ orig_ev_vars
813 ; (sc_dicts, sc_args)
814 <- mapAndUnzipM (tcSuperClass n_ty_args dfun_ev_vars) sc_theta'
816 -- Check that any superclasses gotten from a silent arguemnt
817 -- can be deduced from the originally-specified dfun arguments
818 ; ct_loc <- getCtLoc ScOrigin
819 ; _ <- checkConstraints skol_info inst_tyvars orig_ev_vars $
820 emitFlats $ listToBag $
821 [ mkEvVarX sc ct_loc | sc <- sc_dicts, isSilentEvVar sc ]
823 -- Deal with 'SPECIALISE instance' pragmas
824 -- See Note [SPECIALISE instance pragmas]
825 ; spec_info@(spec_inst_prags,_) <- tcSpecInstPrags dfun_id ibinds
827 -- Typecheck the methods
828 ; (meth_ids, meth_binds)
829 <- tcExtendTyVarEnv inst_tyvars $
830 -- The inst_tyvars scope over the 'where' part
831 -- Those tyvars are inside the dfun_id's type, which is a bit
832 -- bizarre, but OK so long as you realise it!
833 tcInstanceMethods dfun_id clas inst_tyvars dfun_ev_vars
837 -- Create the result bindings
838 ; self_dict <- newEvVar (ClassP clas inst_tys)
839 ; let class_tc = classTyCon clas
840 [dict_constr] = tyConDataCons class_tc
841 dict_bind = mkVarBind self_dict dict_rhs
842 dict_rhs = foldl mk_app inst_constr $
843 map HsVar sc_dicts ++ map (wrapId arg_wrapper) meth_ids
844 inst_constr = L loc $ wrapId (mkWpTyApps inst_tys)
845 (dataConWrapId dict_constr)
846 -- We don't produce a binding for the dict_constr; instead we
847 -- rely on the simplifier to unfold this saturated application
848 -- We do this rather than generate an HsCon directly, because
849 -- it means that the special cases (e.g. dictionary with only one
850 -- member) are dealt with by the common MkId.mkDataConWrapId
851 -- code rather than needing to be repeated here.
853 mk_app :: LHsExpr Id -> HsExpr Id -> LHsExpr Id
854 mk_app fun arg = L loc (HsApp fun (L loc arg))
856 arg_wrapper = mkWpEvVarApps dfun_ev_vars <.> mkWpTyApps (mkTyVarTys inst_tyvars)
858 -- Do not inline the dfun; instead give it a magic DFunFunfolding
859 -- See Note [ClassOp/DFun selection]
860 -- See also note [Single-method classes]
862 | isNewTyCon class_tc
863 = dfun_id `setInlinePragma` alwaysInlinePragma { inl_sat = Just 0 }
865 = dfun_id `setIdUnfolding` mkDFunUnfolding dfun_ty (sc_args ++ meth_args)
866 `setInlinePragma` dfunInlinePragma
867 meth_args = map (DFunPolyArg . Var) meth_ids
869 main_bind = AbsBinds { abs_tvs = inst_tyvars
870 , abs_ev_vars = dfun_ev_vars
871 , abs_exports = [(inst_tyvars, dfun_id_w_fun, self_dict,
872 SpecPrags spec_inst_prags)]
873 , abs_ev_binds = emptyTcEvBinds
874 , abs_binds = unitBag dict_bind }
876 ; return (unitBag (L loc main_bind) `unionBags`
877 listToBag meth_binds)
880 skol_info = InstSkol -- See Note [Subtle interaction of recursion and overlap]
881 dfun_ty = idType dfun_id
882 dfun_id = instanceDFunId ispec
883 loc = getSrcSpan dfun_id
885 ------------------------------
886 tcSuperClass :: Int -> [EvVar] -> PredType -> TcM (EvVar, DFunArg CoreExpr)
887 -- All superclasses should be either
888 -- (a) be one of the arguments to the dfun, of
889 -- (b) be a constant, soluble at top level
890 tcSuperClass n_ty_args ev_vars pred
891 | Just (ev, i) <- find n_ty_args ev_vars
892 = return (ev, DFunLamArg i)
894 = ASSERT2( isEmptyVarSet (tyVarsOfPred pred), ppr pred) -- Constant!
895 do { sc_dict <- emitWanted ScOrigin pred
896 ; return (sc_dict, DFunConstArg (Var sc_dict)) }
899 find i (ev:evs) | pred `eqPred` evVarPred ev = Just (ev, i)
900 | otherwise = find (i+1) evs
902 ------------------------------
903 tcSpecInstPrags :: DFunId -> InstBindings Name
904 -> TcM ([Located TcSpecPrag], PragFun)
905 tcSpecInstPrags _ (NewTypeDerived {})
906 = return ([], \_ -> [])
907 tcSpecInstPrags dfun_id (VanillaInst binds uprags _)
908 = do { spec_inst_prags <- mapM (wrapLocM (tcSpecInst dfun_id)) $
909 filter isSpecInstLSig uprags
910 -- The filter removes the pragmas for methods
911 ; return (spec_inst_prags, mkPragFun uprags binds) }
914 Note [Silent Superclass Arguments]
915 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
916 Consider the following (extreme) situation:
917 class C a => D a where ...
918 instance D [a] => D [a] where ...
919 Although this looks wrong (assume D [a] to prove D [a]), it is only a
920 more extreme case of what happens with recursive dictionaries.
922 To implement the dfun we must generate code for the superclass C [a],
923 which we can get by superclass selection from the supplied argument!
925 dfun :: forall a. D [a] -> D [a]
926 dfun = \d::D [a] -> MkD (scsel d) ..
928 However this means that if we later encounter a situation where
929 we have a [Wanted] dw::D [a] we could solve it thus:
931 Although recursive, this binding would pass the TcSMonadisGoodRecEv
932 check because it appears as guarded. But in reality, it will make a
933 bottom superclass. The trouble is that isGoodRecEv can't "see" the
934 superclass-selection inside dfun.
936 Our solution to this problem is to change the way ‘dfuns’ are created
937 for instances, so that we pass as first arguments to the dfun some
938 ``silent superclass arguments’’, which are the immediate superclasses
939 of the dictionary we are trying to construct. In our example:
940 dfun :: forall a. (C [a], D [a] -> D [a]
941 dfun = \(dc::C [a]) (dd::D [a]) -> DOrd dc ...
945 -----------------------------------------------------------
946 DFun Superclass Invariant
947 ~~~~~~~~~~~~~~~~~~~~~~~~
948 In the body of a DFun, every superclass argument to the
949 returned dictionary is
950 either * one of the arguments of the DFun,
951 or * constant, bound at top level
952 -----------------------------------------------------------
954 This means that no superclass is hidden inside a dfun application, so
955 the counting argument in isGoodRecEv (more dfun calls than superclass
956 selections) works correctly.
958 The extra arguments required to satisfy the DFun Superclass Invariant
959 always come first, and are called the "silent" arguments. DFun types
960 are built (only) by MkId.mkDictFunId, so that is where we decide
961 what silent arguments are to be added.
963 This net effect is that it is safe to treat a dfun application as
964 wrapping a dictionary constructor around its arguments (in particular,
965 a dfun never picks superclasses from the arguments under the dictionary
968 In our example, if we had [Wanted] dw :: D [a] we would get via the instance:
970 [Wanted] (d1 :: C [a])
971 [Wanted] (d2 :: D [a])
972 [Derived] (d :: D [a])
973 [Derived] (scd :: C [a]) scd := scsel d
974 [Derived] (scd2 :: C [a]) scd2 := scsel d2
976 And now, though we *can* solve:
978 we will get an isGoodRecEv failure when we try to solve:
983 Test case SCLoop tests this fix.
985 Note [SPECIALISE instance pragmas]
986 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
989 instance (Ix a, Ix b) => Ix (a,b) where
990 {-# SPECIALISE instance Ix (Int,Int) #-}
993 We do *not* want to make a specialised version of the dictionary
994 function. Rather, we want specialised versions of each method.
995 Thus we should generate something like this:
997 $dfIx :: (Ix a, Ix x) => Ix (a,b)
998 {- DFUN [$crange, ...] -}
999 $dfIx da db = Ix ($crange da db) (...other methods...)
1001 $dfIxPair :: (Ix a, Ix x) => Ix (a,b)
1002 {- DFUN [$crangePair, ...] -}
1003 $dfIxPair = Ix ($crangePair da db) (...other methods...)
1005 $crange :: (Ix a, Ix b) -> ((a,b),(a,b)) -> [(a,b)]
1006 {-# SPECIALISE $crange :: ((Int,Int),(Int,Int)) -> [(Int,Int)] #-}
1007 $crange da db = <blah>
1009 {-# RULE range ($dfIx da db) = $crange da db #-}
1013 * The RULE is unaffected by the specialisation. We don't want to
1014 specialise $dfIx, because then it would need a specialised RULE
1015 which is a pain. The single RULE works fine at all specialisations.
1016 See Note [How instance declarations are translated] above
1018 * Instead, we want to specialise the *method*, $crange
1020 In practice, rather than faking up a SPECIALISE pragama for each
1021 method (which is painful, since we'd have to figure out its
1022 specialised type), we call tcSpecPrag *as if* were going to specialise
1023 $dfIx -- you can see that in the call to tcSpecInst. That generates a
1024 SpecPrag which, as it turns out, can be used unchanged for each method.
1025 The "it turns out" bit is delicate, but it works fine!
1028 tcSpecInst :: Id -> Sig Name -> TcM TcSpecPrag
1029 tcSpecInst dfun_id prag@(SpecInstSig hs_ty)
1030 = addErrCtxt (spec_ctxt prag) $
1031 do { let name = idName dfun_id
1032 ; (tyvars, theta, clas, tys) <- tcHsInstHead hs_ty
1033 ; let (_, spec_dfun_ty) = mkDictFunTy tyvars theta clas tys
1035 ; co_fn <- tcSubType (SpecPragOrigin name) SpecInstCtxt
1036 (idType dfun_id) spec_dfun_ty
1037 ; return (SpecPrag dfun_id co_fn defaultInlinePragma) }
1039 spec_ctxt prag = hang (ptext (sLit "In the SPECIALISE pragma")) 2 (ppr prag)
1041 tcSpecInst _ _ = panic "tcSpecInst"
1044 %************************************************************************
1046 Type-checking an instance method
1048 %************************************************************************
1051 - Make the method bindings, as a [(NonRec, HsBinds)], one per method
1052 - Remembering to use fresh Name (the instance method Name) as the binder
1053 - Bring the instance method Ids into scope, for the benefit of tcInstSig
1054 - Use sig_fn mapping instance method Name -> instance tyvars
1056 - Use tcValBinds to do the checking
1059 tcInstanceMethods :: DFunId -> Class -> [TcTyVar]
1062 -> ([Located TcSpecPrag], PragFun)
1064 -> InstBindings Name
1065 -> TcM ([Id], [LHsBind Id])
1066 -- The returned inst_meth_ids all have types starting
1067 -- forall tvs. theta => ...
1068 tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
1069 (spec_inst_prags, prag_fn)
1070 op_items (VanillaInst binds _ standalone_deriv)
1071 = mapAndUnzipM tc_item op_items
1073 ----------------------
1074 tc_item :: (Id, DefMeth) -> TcM (Id, LHsBind Id)
1075 tc_item (sel_id, dm_info)
1076 = case findMethodBind (idName sel_id) binds of
1077 Just user_bind -> tc_body sel_id standalone_deriv user_bind
1078 Nothing -> tc_default sel_id dm_info
1080 ----------------------
1081 tc_body :: Id -> Bool -> LHsBind Name -> TcM (TcId, LHsBind Id)
1082 tc_body sel_id generated_code rn_bind
1083 = add_meth_ctxt sel_id generated_code rn_bind $
1084 do { (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars
1086 ; let prags = prag_fn (idName sel_id)
1087 ; meth_id1 <- addInlinePrags meth_id prags
1088 ; spec_prags <- tcSpecPrags meth_id1 prags
1089 ; bind <- tcInstanceMethodBody InstSkol
1091 meth_id1 local_meth_id meth_sig_fn
1092 (mk_meth_spec_prags meth_id1 spec_prags)
1094 ; return (meth_id1, bind) }
1096 ----------------------
1097 tc_default :: Id -> DefMeth -> TcM (TcId, LHsBind Id)
1099 tc_default sel_id (GenDefMeth dm_name)
1100 = do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id dm_name
1101 ; tc_body sel_id False {- Not generated code? -} meth_bind }
1103 tc_default sel_id GenDefMeth -- Derivable type classes stuff
1104 = do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id
1105 ; tc_body sel_id False {- Not generated code? -} meth_bind }
1107 tc_default sel_id NoDefMeth -- No default method at all
1108 = do { warnMissingMethod sel_id
1109 ; (meth_id, _) <- mkMethIds clas tyvars dfun_ev_vars
1111 ; return (meth_id, mkVarBind meth_id $
1112 mkLHsWrap lam_wrapper error_rhs) }
1114 error_rhs = L loc $ HsApp error_fun error_msg
1115 error_fun = L loc $ wrapId (WpTyApp meth_tau) nO_METHOD_BINDING_ERROR_ID
1116 error_msg = L loc (HsLit (HsStringPrim (mkFastString error_string)))
1117 meth_tau = funResultTy (applyTys (idType sel_id) inst_tys)
1118 error_string = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
1119 lam_wrapper = mkWpTyLams tyvars <.> mkWpLams dfun_ev_vars
1121 tc_default sel_id (DefMeth dm_name) -- A polymorphic default method
1122 = do { -- Build the typechecked version directly,
1123 -- without calling typecheck_method;
1124 -- see Note [Default methods in instances]
1125 -- Generate /\as.\ds. let self = df as ds
1126 -- in $dm inst_tys self
1127 -- The 'let' is necessary only because HsSyn doesn't allow
1128 -- you to apply a function to a dictionary *expression*.
1130 ; self_dict <- newEvVar (ClassP clas inst_tys)
1131 ; let self_ev_bind = EvBind self_dict $
1132 EvDFunApp dfun_id (mkTyVarTys tyvars) dfun_ev_vars
1134 ; (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars
1136 ; dm_id <- tcLookupId dm_name
1137 ; let dm_inline_prag = idInlinePragma dm_id
1138 rhs = HsWrap (mkWpEvVarApps [self_dict] <.> mkWpTyApps inst_tys) $
1141 meth_bind = L loc $ VarBind { var_id = local_meth_id
1142 , var_rhs = L loc rhs
1143 , var_inline = False }
1144 meth_id1 = meth_id `setInlinePragma` dm_inline_prag
1145 -- Copy the inline pragma (if any) from the default
1146 -- method to this version. Note [INLINE and default methods]
1148 bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars
1149 , abs_exports = [( tyvars, meth_id1, local_meth_id
1150 , mk_meth_spec_prags meth_id1 [])]
1151 , abs_ev_binds = EvBinds (unitBag self_ev_bind)
1152 , abs_binds = unitBag meth_bind }
1153 -- Default methods in an instance declaration can't have their own
1154 -- INLINE or SPECIALISE pragmas. It'd be possible to allow them, but
1155 -- currently they are rejected with
1156 -- "INLINE pragma lacks an accompanying binding"
1158 ; return (meth_id1, L loc bind) }
1160 ----------------------
1161 mk_meth_spec_prags :: Id -> [LTcSpecPrag] -> TcSpecPrags
1162 -- Adapt the SPECIALISE pragmas to work for this method Id
1163 -- There are two sources:
1164 -- * spec_inst_prags: {-# SPECIALISE instance :: <blah> #-}
1165 -- These ones have the dfun inside, but [perhaps surprisingly]
1166 -- the correct wrapper
1167 -- * spec_prags_for_me: {-# SPECIALISE op :: <blah> #-}
1168 mk_meth_spec_prags meth_id spec_prags_for_me
1169 = SpecPrags (spec_prags_for_me ++
1170 [ L loc (SpecPrag meth_id wrap inl)
1171 | L loc (SpecPrag _ wrap inl) <- spec_inst_prags])
1173 loc = getSrcSpan dfun_id
1174 meth_sig_fn _ = Just ([],loc) -- The 'Just' says "yes, there's a type sig"
1175 -- But there are no scoped type variables from local_method_id
1176 -- Only the ones from the instance decl itself, which are already
1177 -- in scope. Example:
1178 -- class C a where { op :: forall b. Eq b => ... }
1179 -- instance C [c] where { op = <rhs> }
1180 -- In <rhs>, 'c' is scope but 'b' is not!
1182 -- For instance decls that come from standalone deriving clauses
1183 -- we want to print out the full source code if there's an error
1184 -- because otherwise the user won't see the code at all
1185 add_meth_ctxt sel_id generated_code rn_bind thing
1186 | generated_code = addLandmarkErrCtxt (derivBindCtxt sel_id clas inst_tys rn_bind) thing
1190 tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
1191 _ op_items (NewTypeDerived coi _)
1194 -- class Show b => Foo a b where
1195 -- op :: a -> b -> b
1196 -- newtype N a = MkN (Tree [a])
1197 -- deriving instance (Show p, Foo Int p) => Foo Int (N p)
1198 -- -- NB: standalone deriving clause means
1199 -- -- that the contex is user-specified
1200 -- Hence op :: forall a b. Foo a b => a -> b -> b
1202 -- We're going to make an instance like
1203 -- instance (Show p, Foo Int p) => Foo Int (N p)
1206 -- $copT :: forall p. (Show p, Foo Int p) => Int -> N p -> N p
1207 -- $copT p (d1:Show p) (d2:Foo Int p)
1208 -- = op Int (Tree [p]) rep_d |> op_co
1210 -- rep_d :: Foo Int (Tree [p]) = ...d1...d2...
1211 -- op_co :: (Int -> Tree [p] -> Tree [p]) ~ (Int -> T p -> T p)
1212 -- We get op_co by substituting [Int/a] and [co/b] in type for op
1213 -- where co : [p] ~ T p
1215 -- Notice that the dictionary bindings "..d1..d2.." must be generated
1216 -- by the constraint solver, since the <context> may be
1219 = do { rep_d_stuff <- checkConstraints InstSkol tyvars dfun_ev_vars $
1220 emitWanted ScOrigin rep_pred
1222 ; mapAndUnzipM (tc_item rep_d_stuff) op_items }
1224 loc = getSrcSpan dfun_id
1226 inst_tvs = fst (tcSplitForAllTys (idType dfun_id))
1227 Just (init_inst_tys, _) = snocView inst_tys
1228 rep_ty = pFst (coercionKind co) -- [p]
1229 rep_pred = mkClassPred clas (init_inst_tys ++ [rep_ty])
1232 co = substCoWithTys inst_tvs (mkTyVarTys tyvars) $
1236 tc_item :: (TcEvBinds, EvVar) -> (Id, DefMeth) -> TcM (TcId, LHsBind TcId)
1237 tc_item (rep_ev_binds, rep_d) (sel_id, _)
1238 = do { (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars
1241 ; let meth_rhs = wrapId (mk_op_wrapper sel_id rep_d) sel_id
1242 meth_bind = VarBind { var_id = local_meth_id
1243 , var_rhs = L loc meth_rhs
1244 , var_inline = False }
1246 bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars
1247 , abs_exports = [(tyvars, meth_id,
1248 local_meth_id, noSpecPrags)]
1249 , abs_ev_binds = rep_ev_binds
1250 , abs_binds = unitBag $ L loc meth_bind }
1252 ; return (meth_id, L loc bind) }
1255 mk_op_wrapper :: Id -> EvVar -> HsWrapper
1256 mk_op_wrapper sel_id rep_d
1257 = WpCast (liftCoSubstWith sel_tvs (map mkReflCo init_inst_tys ++ [co])
1259 <.> WpEvApp (EvId rep_d)
1260 <.> mkWpTyApps (init_inst_tys ++ [rep_ty])
1262 (sel_tvs, sel_rho) = tcSplitForAllTys (idType sel_id)
1263 (_, local_meth_ty) = tcSplitPredFunTy_maybe sel_rho
1264 `orElse` pprPanic "tcInstanceMethods" (ppr sel_id)
1266 ----------------------
1267 mkMethIds :: Class -> [TcTyVar] -> [EvVar] -> [TcType] -> Id -> TcM (TcId, TcId)
1268 mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id
1269 = do { uniq <- newUnique
1270 ; let meth_name = mkDerivedInternalName mkClassOpAuxOcc uniq sel_name
1271 ; local_meth_name <- newLocalName sel_name
1272 -- Base the local_meth_name on the selector name, becuase
1273 -- type errors from tcInstanceMethodBody come from here
1275 ; let meth_id = mkLocalId meth_name meth_ty
1276 local_meth_id = mkLocalId local_meth_name local_meth_ty
1277 ; return (meth_id, local_meth_id) }
1279 local_meth_ty = instantiateMethod clas sel_id inst_tys
1280 meth_ty = mkForAllTys tyvars $ mkPiTypes dfun_ev_vars local_meth_ty
1281 sel_name = idName sel_id
1283 ----------------------
1284 wrapId :: HsWrapper -> id -> HsExpr id
1285 wrapId wrapper id = mkHsWrap wrapper (HsVar id)
1287 derivBindCtxt :: Id -> Class -> [Type ] -> LHsBind Name -> SDoc
1288 derivBindCtxt sel_id clas tys _bind
1289 = vcat [ ptext (sLit "When typechecking the code for ") <+> quotes (ppr sel_id)
1290 , nest 2 (ptext (sLit "in a standalone derived instance for")
1291 <+> quotes (pprClassPred clas tys) <> colon)
1292 , nest 2 $ ptext (sLit "To see the code I am typechecking, use -ddump-deriv") ]
1295 -- , nest 2 $ pprSetDepth AllTheWay $ ppr bind ]
1297 warnMissingMethod :: Id -> TcM ()
1298 warnMissingMethod sel_id
1299 = do { warn <- doptM Opt_WarnMissingMethods
1300 ; warnTc (warn -- Warn only if -fwarn-missing-methods
1301 && not (startsWithUnderscore (getOccName sel_id)))
1302 -- Don't warn about _foo methods
1303 (ptext (sLit "No explicit method nor default method for")
1304 <+> quotes (ppr sel_id)) }
1307 Note [Export helper functions]
1308 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1309 We arrange to export the "helper functions" of an instance declaration,
1310 so that they are not subject to preInlineUnconditionally, even if their
1311 RHS is trivial. Reason: they are mentioned in the DFunUnfolding of
1312 the dict fun as Ids, not as CoreExprs, so we can't substitute a
1313 non-variable for them.
1315 We could change this by making DFunUnfoldings have CoreExprs, but it
1316 seems a bit simpler this way.
1318 Note [Default methods in instances]
1319 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1326 instance Baz Int Int
1328 From the class decl we get
1330 $dmfoo :: forall v x. Baz v x => x -> x
1333 Notice that the type is ambiguous. That's fine, though. The instance
1336 $dBazIntInt = MkBaz fooIntInt
1337 fooIntInt = $dmfoo Int Int $dBazIntInt
1339 BUT this does mean we must generate the dictionary translation of
1340 fooIntInt directly, rather than generating source-code and
1341 type-checking it. That was the bug in Trac #1061. In any case it's
1342 less work to generate the translated version!
1344 Note [INLINE and default methods]
1345 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1346 Default methods need special case. They are supposed to behave rather like
1347 macros. For exmample
1350 op1, op2 :: Bool -> a -> a
1353 op1 b x = op2 (not b) x
1355 instance Foo Int where
1356 -- op1 via default method
1359 The instance declaration should behave
1361 just as if 'op1' had been defined with the
1362 code, and INLINE pragma, from its original
1365 That is, just as if you'd written
1367 instance Foo Int where
1371 op1 b x = op2 (not b) x
1373 So for the above example we generate:
1376 {-# INLINE $dmop1 #-}
1377 -- $dmop1 has an InlineCompulsory unfolding
1378 $dmop1 d b x = op2 d (not b) x
1380 $fFooInt = MkD $cop1 $cop2
1382 {-# INLINE $cop1 #-}
1383 $cop1 = $dmop1 $fFooInt
1389 * We *copy* any INLINE pragma from the default method $dmop1 to the
1390 instance $cop1. Otherwise we'll just inline the former in the
1391 latter and stop, which isn't what the user expected
1393 * Regardless of its pragma, we give the default method an
1394 unfolding with an InlineCompulsory source. That means
1395 that it'll be inlined at every use site, notably in
1396 each instance declaration, such as $cop1. This inlining
1397 must happen even though
1398 a) $dmop1 is not saturated in $cop1
1399 b) $cop1 itself has an INLINE pragma
1401 It's vital that $dmop1 *is* inlined in this way, to allow the mutual
1402 recursion between $fooInt and $cop1 to be broken
1404 * To communicate the need for an InlineCompulsory to the desugarer
1405 (which makes the Unfoldings), we use the IsDefaultMethod constructor
1409 %************************************************************************
1411 \subsection{Error messages}
1413 %************************************************************************
1416 instDeclCtxt1 :: LHsType Name -> SDoc
1417 instDeclCtxt1 hs_inst_ty
1418 = inst_decl_ctxt (case unLoc hs_inst_ty of
1419 HsForAllTy _ _ _ (L _ (HsPredTy pred)) -> ppr pred
1420 HsPredTy pred -> ppr pred
1421 _ -> ppr hs_inst_ty) -- Don't expect this
1422 instDeclCtxt2 :: Type -> SDoc
1423 instDeclCtxt2 dfun_ty
1424 = inst_decl_ctxt (ppr (mkClassPred cls tys))
1426 (_,_,cls,tys) = tcSplitDFunTy dfun_ty
1428 inst_decl_ctxt :: SDoc -> SDoc
1429 inst_decl_ctxt doc = ptext (sLit "In the instance declaration for") <+> quotes doc
1431 atInstCtxt :: Name -> SDoc
1432 atInstCtxt name = ptext (sLit "In the associated type instance for") <+>
1435 mustBeVarArgErr :: Type -> SDoc
1436 mustBeVarArgErr ty =
1437 sep [ ptext (sLit "Arguments that do not correspond to a class parameter") <+>
1438 ptext (sLit "must be variables")
1439 , ptext (sLit "Instead of a variable, found") <+> ppr ty
1442 wrongATArgErr :: Type -> Type -> SDoc
1443 wrongATArgErr ty instTy =
1444 sep [ ptext (sLit "Type indexes must match class instance head")
1445 , ptext (sLit "Found") <+> quotes (ppr ty)
1446 <+> ptext (sLit "but expected") <+> quotes (ppr instTy)
1449 tooManyParmsErr :: Located Name -> SDoc
1450 tooManyParmsErr tc_name
1451 = ptext (sLit "Family instance has too many parameters:") <+>
1452 quotes (ppr tc_name)
1454 tooFewParmsErr :: Arity -> SDoc
1455 tooFewParmsErr arity
1456 = ptext (sLit "Family instance has too few parameters; expected") <+>
1459 wrongNumberOfParmsErr :: Arity -> SDoc
1460 wrongNumberOfParmsErr exp_arity
1461 = ptext (sLit "Number of parameters must match family declaration; expected")
1464 badBootFamInstDeclErr :: SDoc
1465 badBootFamInstDeclErr
1466 = ptext (sLit "Illegal family instance in hs-boot file")
1468 notFamily :: TyCon -> SDoc
1470 = vcat [ ptext (sLit "Illegal family instance for") <+> quotes (ppr tycon)
1471 , nest 2 $ parens (ppr tycon <+> ptext (sLit "is not an indexed type family"))]
1473 wrongKindOfFamily :: TyCon -> SDoc
1474 wrongKindOfFamily family
1475 = ptext (sLit "Wrong category of family instance; declaration was for a")
1478 kindOfFamily | isSynTyCon family = ptext (sLit "type synonym")
1479 | isAlgTyCon family = ptext (sLit "data type")
1480 | otherwise = pprPanic "wrongKindOfFamily" (ppr family)