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 )
23 import MkCore ( nO_METHOD_BINDING_ERROR_ID )
26 import RnSource ( addTcgDUs )
27 import TcSimplify( simplifySuperClass )
36 import CoreUtils ( mkPiTypes )
37 import CoreUnfold ( mkDFunUnfolding )
38 import CoreSyn ( Expr(Var) )
51 import Maybes ( orElse )
56 #include "HsVersions.h"
59 Typechecking instance declarations is done in two passes. The first
60 pass, made by @tcInstDecls1@, collects information to be used in the
63 This pre-processed info includes the as-yet-unprocessed bindings
64 inside the instance declaration. These are type-checked in the second
65 pass, when the class-instance envs and GVE contain all the info from
66 all the instance and value decls. Indeed that's the reason we need
67 two passes over the instance decls.
70 Note [How instance declarations are translated]
71 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
72 Here is how we translation instance declarations into Core
76 op1, op2 :: Ix b => a -> b -> b
80 {-# INLINE [2] op1 #-}
84 op1,op2 :: forall a. C a => forall b. Ix b => a -> b -> b
88 -- Default methods get the 'self' dictionary as argument
89 -- so they can call other methods at the same type
90 -- Default methods get the same type as their method selector
91 $dmop2 :: forall a. C a => forall b. Ix b => a -> b -> b
92 $dmop2 = /\a. \(d:C a). /\b. \(d2: Ix b). <dm-rhs>
93 -- NB: type variables 'a' and 'b' are *both* in scope in <dm-rhs>
94 -- Note [Tricky type variable scoping]
96 -- A top-level definition for each instance method
97 -- Here op1_i, op2_i are the "instance method Ids"
98 -- The INLINE pragma comes from the user pragma
99 {-# INLINE [2] op1_i #-} -- From the instance decl bindings
100 op1_i, op2_i :: forall a. C a => forall b. Ix b => [a] -> b -> b
101 op1_i = /\a. \(d:C a).
104 -- Note [Subtle interaction of recursion and overlap]
106 local_op1 :: forall b. Ix b => [a] -> b -> b
108 -- Source code; run the type checker on this
109 -- NB: Type variable 'a' (but not 'b') is in scope in <rhs>
110 -- Note [Tricky type variable scoping]
114 op2_i = /\a \d:C a. $dmop2 [a] (df_i a d)
116 -- The dictionary function itself
117 {-# NOINLINE CONLIKE df_i #-} -- Never inline dictionary functions
118 df_i :: forall a. C a -> C [a]
119 df_i = /\a. \d:C a. MkC (op1_i a d) (op2_i a d)
120 -- But see Note [Default methods in instances]
121 -- We can't apply the type checker to the default-method call
123 -- Use a RULE to short-circuit applications of the class ops
124 {-# RULE "op1@C[a]" forall a, d:C a.
125 op1 [a] (df_i d) = op1_i a d #-}
127 Note [Instances and loop breakers]
128 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
129 * Note that df_i may be mutually recursive with both op1_i and op2_i.
130 It's crucial that df_i is not chosen as the loop breaker, even
131 though op1_i has a (user-specified) INLINE pragma.
133 * Instead the idea is to inline df_i into op1_i, which may then select
134 methods from the MkC record, and thereby break the recursion with
135 df_i, leaving a *self*-recurisve op1_i. (If op1_i doesn't call op at
136 the same type, it won't mention df_i, so there won't be recursion in
139 * If op1_i is marked INLINE by the user there's a danger that we won't
140 inline df_i in it, and that in turn means that (since it'll be a
141 loop-breaker because df_i isn't), op1_i will ironically never be
142 inlined. But this is OK: the recursion breaking happens by way of
143 a RULE (the magic ClassOp rule above), and RULES work inside InlineRule
144 unfoldings. See Note [RULEs enabled in SimplGently] in SimplUtils
146 Note [ClassOp/DFun selection]
147 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
148 One thing we see a lot is stuff like
150 where 'op2' is a ClassOp and 'df' is DFun. Now, we could inline *both*
151 'op2' and 'df' to get
152 case (MkD ($cop1 d1 d2) ($cop2 d1 d2) ... of
153 MkD _ op2 _ _ _ -> op2
154 And that will reduce to ($cop2 d1 d2) which is what we wanted.
156 But it's tricky to make this work in practice, because it requires us to
157 inline both 'op2' and 'df'. But neither is keen to inline without having
158 seen the other's result; and it's very easy to get code bloat (from the
159 big intermediate) if you inline a bit too much.
161 Instead we use a cunning trick.
162 * We arrange that 'df' and 'op2' NEVER inline.
164 * We arrange that 'df' is ALWAYS defined in the sylised form
165 df d1 d2 = MkD ($cop1 d1 d2) ($cop2 d1 d2) ...
167 * We give 'df' a magical unfolding (DFunUnfolding [$cop1, $cop2, ..])
168 that lists its methods.
170 * We make CoreUnfold.exprIsConApp_maybe spot a DFunUnfolding and return
171 a suitable constructor application -- inlining df "on the fly" as it
174 * We give the ClassOp 'op2' a BuiltinRule that extracts the right piece
175 iff its argument satisfies exprIsConApp_maybe. This is done in
178 * We make 'df' CONLIKE, so that shared uses stil match; eg
180 in ...(op2 d)...(op1 d)...
182 Note [Single-method classes]
183 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
184 If the class has just one method (or, more accurately, just one element
185 of {superclasses + methods}), then we still use the *same* strategy
187 class C a where op :: a -> a
188 instance C a => C [a] where op = <blah>
190 We translate the class decl into a newtype, which just gives
193 axiom Co:C a :: C a ~ (a->a)
195 op :: forall a. C a -> (a -> a)
196 op a d = d |> (Co:C a)
198 MkC :: forall a. (a->a) -> C a
199 MkC = /\a.\op. op |> (sym Co:C a)
201 df :: forall a. C a => C [a]
202 {-# NOINLINE df DFun[ $cop_list ] #-}
203 df = /\a. \d. MkC ($cop_list a d)
205 $cop_list :: forall a. C a => [a] -> [a]
208 The "constructor" MkC expands to a cast, as does the class-op selector.
209 The RULE works just like for multi-field dictionaries:
211 * (df a d) returns (Just (MkC,..,[$cop_list a d]))
212 to exprIsConApp_Maybe
214 * The RULE for op picks the right result
216 This is a bit of a hack, because (df a d) isn't *really* a constructor
217 application. But it works just fine in this case, exprIsConApp_maybe
218 is otherwise used only when we hit a case expression which will have
219 a real data constructor in it.
221 The biggest reason for doing it this way, apart from uniformity, is
222 that we want to be very careful when we have
223 instance C a => C [a] where
226 then we'll get an INLINE pragma on $cop_list but it's important that
227 $cop_list only inlines when it's applied to *two* arguments (the
228 dictionary and the list argument
230 The danger is that we'll get something like
231 op_list :: C a => [a] -> [a]
232 op_list = /\a.\d. $cop_list a d
233 and then we'll eta expand, and then we'll inline TOO EARLY. This happened in
234 Trac #3772 and I spent far too long fiddling around trying to fix it.
235 Look at the test for Trac #3772.
237 (Note: re-reading the above, I can't see how using the
238 uniform story solves the problem.)
240 Note [Subtle interaction of recursion and overlap]
241 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
243 class C a where { op1,op2 :: a -> a }
244 instance C a => C [a] where
245 op1 x = op2 x ++ op2 x
247 instance C [Int] where
250 When type-checking the C [a] instance, we need a C [a] dictionary (for
251 the call of op2). If we look up in the instance environment, we find
252 an overlap. And in *general* the right thing is to complain (see Note
253 [Overlapping instances] in InstEnv). But in *this* case it's wrong to
254 complain, because we just want to delegate to the op2 of this same
257 Why is this justified? Because we generate a (C [a]) constraint in
258 a context in which 'a' cannot be instantiated to anything that matches
259 other overlapping instances, or else we would not be excecuting this
260 version of op1 in the first place.
262 It might even be a bit disguised:
264 nullFail :: C [a] => [a] -> [a]
265 nullFail x = op2 x ++ op2 x
267 instance C a => C [a] where
270 Precisely this is used in package 'regex-base', module Context.hs.
271 See the overlapping instances for RegexContext, and the fact that they
272 call 'nullFail' just like the example above. The DoCon package also
273 does the same thing; it shows up in module Fraction.hs
275 Conclusion: when typechecking the methods in a C [a] instance, we want
276 to have C [a] available. That is why we have the strange local
277 definition for 'this' in the definition of op1_i in the example above.
278 We can typecheck the defintion of local_op1, and when doing tcSimplifyCheck
279 we supply 'this' as a given dictionary. Only needed, though, if there
280 are some type variables involved; otherwise there can be no overlap and
283 Note [Tricky type variable scoping]
284 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
287 op1, op2 :: Ix b => a -> b -> b
290 instance C a => C [a]
291 {-# INLINE [2] op1 #-}
294 note that 'a' and 'b' are *both* in scope in <dm-rhs>, but only 'a' is
295 in scope in <rhs>. In particular, we must make sure that 'b' is in
296 scope when typechecking <dm-rhs>. This is achieved by subFunTys,
297 which brings appropriate tyvars into scope. This happens for both
298 <dm-rhs> and for <rhs>, but that doesn't matter: the *renamer* will have
299 complained if 'b' is mentioned in <rhs>.
303 %************************************************************************
305 \subsection{Extracting instance decls}
307 %************************************************************************
309 Gather up the instance declarations from their various sources
312 tcInstDecls1 -- Deal with both source-code and imported instance decls
313 :: [LTyClDecl Name] -- For deriving stuff
314 -> [LInstDecl Name] -- Source code instance decls
315 -> [LDerivDecl Name] -- Source code stand-alone deriving decls
316 -> TcM (TcGblEnv, -- The full inst env
317 [InstInfo Name], -- Source-code instance decls to process;
318 -- contains all dfuns for this module
319 HsValBinds Name) -- Supporting bindings for derived instances
321 tcInstDecls1 tycl_decls inst_decls deriv_decls
323 do { -- Stop if addInstInfos etc discovers any errors
324 -- (they recover, so that we get more than one error each
327 -- (1) Do class and family instance declarations
328 ; idx_tycons <- mapAndRecoverM (tcFamInstDecl TopLevel) $
329 filter (isFamInstDecl . unLoc) tycl_decls
330 ; local_info_tycons <- mapAndRecoverM tcLocalInstDecl1 inst_decls
333 at_tycons_s) = unzip local_info_tycons
334 ; at_idx_tycons = concat at_tycons_s ++ idx_tycons
335 ; clas_decls = filter (isClassDecl.unLoc) tycl_decls
336 ; implicit_things = concatMap implicitTyThings at_idx_tycons
337 ; aux_binds = mkRecSelBinds at_idx_tycons
340 -- (2) Add the tycons of indexed types and their implicit
341 -- tythings to the global environment
342 ; tcExtendGlobalEnv (at_idx_tycons ++ implicit_things) $ do {
344 -- (3) Instances from generic class declarations
345 ; generic_inst_info <- getGenericInstances clas_decls
347 -- Next, construct the instance environment so far, consisting
349 -- (a) local instance decls
350 -- (b) generic instances
351 -- (c) local family instance decls
352 ; addInsts local_info $
353 addInsts generic_inst_info $
354 addFamInsts at_idx_tycons $ do {
356 -- (4) Compute instances from "deriving" clauses;
357 -- This stuff computes a context for the derived instance
358 -- decl, so it needs to know about all the instances possible
359 -- NB: class instance declarations can contain derivings as
360 -- part of associated data type declarations
361 failIfErrsM -- If the addInsts stuff gave any errors, don't
362 -- try the deriving stuff, becuase that may give
364 ; (deriv_inst_info, deriv_binds, deriv_dus)
365 <- tcDeriving tycl_decls inst_decls deriv_decls
366 ; gbl_env <- addInsts deriv_inst_info getGblEnv
367 ; return ( addTcgDUs gbl_env deriv_dus,
368 generic_inst_info ++ deriv_inst_info ++ local_info,
369 aux_binds `plusHsValBinds` deriv_binds)
372 addInsts :: [InstInfo Name] -> TcM a -> TcM a
373 addInsts infos thing_inside
374 = tcExtendLocalInstEnv (map iSpec infos) thing_inside
376 addFamInsts :: [TyThing] -> TcM a -> TcM a
377 addFamInsts tycons thing_inside
378 = tcExtendLocalFamInstEnv (map mkLocalFamInstTyThing tycons) thing_inside
380 mkLocalFamInstTyThing (ATyCon tycon) = mkLocalFamInst tycon
381 mkLocalFamInstTyThing tything = pprPanic "TcInstDcls.addFamInsts"
386 tcLocalInstDecl1 :: LInstDecl Name
387 -> TcM (InstInfo Name, [TyThing])
388 -- A source-file instance declaration
389 -- Type-check all the stuff before the "where"
391 -- We check for respectable instance type, and context
392 tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats))
394 addErrCtxt (instDeclCtxt1 poly_ty) $
396 do { is_boot <- tcIsHsBoot
397 ; checkTc (not is_boot || (isEmptyLHsBinds binds && null uprags))
400 ; (tyvars, theta, tau) <- tcHsInstHead poly_ty
402 -- Now, check the validity of the instance.
403 ; (clas, inst_tys) <- checkValidInstance poly_ty tyvars theta tau
405 -- Next, process any associated types.
406 ; idx_tycons <- recoverM (return []) $
407 do { idx_tycons <- checkNoErrs $
408 mapAndRecoverM (tcFamInstDecl NotTopLevel) ats
409 ; checkValidAndMissingATs clas (tyvars, inst_tys)
411 ; return idx_tycons }
413 -- Finally, construct the Core representation of the instance.
414 -- (This no longer includes the associated types.)
415 ; dfun_name <- newDFunName clas inst_tys (getLoc poly_ty)
416 -- Dfun location is that of instance *header*
417 ; overlap_flag <- getOverlapFlag
418 ; let (eq_theta,dict_theta) = partition isEqPred theta
419 theta' = eq_theta ++ dict_theta
420 dfun = mkDictFunId dfun_name tyvars theta' clas inst_tys
421 ispec = mkLocalInstance dfun overlap_flag
423 ; return (InstInfo { iSpec = ispec,
424 iBinds = VanillaInst binds uprags False },
428 -- We pass in the source form and the type checked form of the ATs. We
429 -- really need the source form only to be able to produce more informative
431 checkValidAndMissingATs :: Class
432 -> ([TyVar], [TcType]) -- instance types
433 -> [(LTyClDecl Name, -- source form of AT
434 TyThing)] -- Core form of AT
436 checkValidAndMissingATs clas inst_tys ats
437 = do { -- Issue a warning for each class AT that is not defined in this
439 ; let class_ats = map tyConName (classATs clas)
440 defined_ats = listToNameSet . map (tcdName.unLoc.fst) $ ats
441 omitted = filterOut (`elemNameSet` defined_ats) class_ats
442 ; warn <- doptM Opt_WarnMissingMethods
443 ; mapM_ (warnTc warn . omittedATWarn) omitted
445 -- Ensure that all AT indexes that correspond to class parameters
446 -- coincide with the types in the instance head. All remaining
447 -- AT arguments must be variables. Also raise an error for any
448 -- type instances that are not associated with this class.
449 ; mapM_ (checkIndexes clas inst_tys) ats
452 checkIndexes clas inst_tys (hsAT, ATyCon tycon)
453 -- !!!TODO: check that this does the Right Thing for indexed synonyms, too!
454 = checkIndexes' clas inst_tys hsAT
456 snd . fromJust . tyConFamInst_maybe $ tycon)
457 checkIndexes _ _ _ = panic "checkIndexes"
459 checkIndexes' clas (instTvs, instTys) hsAT (atTvs, atTys)
460 = let atName = tcdName . unLoc $ hsAT
462 setSrcSpan (getLoc hsAT) $
463 addErrCtxt (atInstCtxt atName) $
464 case find ((atName ==) . tyConName) (classATs clas) of
465 Nothing -> addErrTc $ badATErr clas atName -- not in this class
467 -- The following is tricky! We need to deal with three
468 -- complications: (1) The AT possibly only uses a subset of
469 -- the class parameters as indexes and those it uses may be in
470 -- a different order; (2) the AT may have extra arguments,
471 -- which must be type variables; and (3) variables in AT and
472 -- instance head will be different `Name's even if their
473 -- source lexemes are identical.
475 -- e.g. class C a b c where
476 -- data D b a :: * -> * -- NB (1) b a, omits c
477 -- instance C [x] Bool Char where
478 -- data D Bool [x] v = MkD x [v] -- NB (2) v
479 -- -- NB (3) the x in 'instance C...' have differnt
480 -- -- Names to x's in 'data D...'
482 -- Re (1), `poss' contains a permutation vector to extract the
483 -- class parameters in the right order.
485 -- Re (2), we wrap the (permuted) class parameters in a Maybe
486 -- type and use Nothing for any extra AT arguments. (First
487 -- equation of `checkIndex' below.)
489 -- Re (3), we replace any type variable in the AT parameters
490 -- that has the same source lexeme as some variable in the
491 -- instance types with the instance type variable sharing its
495 -- For *associated* type families, gives the position
496 -- of that 'TyVar' in the class argument list (0-indexed)
497 -- e.g. class C a b c where { type F c a :: *->* }
498 -- Then we get Just [2,0]
499 poss = catMaybes [ tv `elemIndex` classTyVars clas
500 | tv <- tyConTyVars atycon]
501 -- We will get Nothings for the "extra" type
502 -- variables in an associated data type
503 -- e.g. class C a where { data D a :: *->* }
504 -- here D gets arity 2 and has two tyvars
506 relevantInstTys = map (instTys !!) poss
507 instArgs = map Just relevantInstTys ++
508 repeat Nothing -- extra arguments
509 renaming = substSameTyVar atTvs instTvs
511 zipWithM_ checkIndex (substTys renaming atTys) instArgs
513 checkIndex ty Nothing
514 | isTyVarTy ty = return ()
515 | otherwise = addErrTc $ mustBeVarArgErr ty
516 checkIndex ty (Just instTy)
517 | ty `tcEqType` instTy = return ()
518 | otherwise = addErrTc $ wrongATArgErr ty instTy
520 listToNameSet = addListToNameSet emptyNameSet
522 substSameTyVar [] _ = emptyTvSubst
523 substSameTyVar (tv:tvs) replacingTvs =
524 let replacement = case find (tv `sameLexeme`) replacingTvs of
525 Nothing -> mkTyVarTy tv
526 Just rtv -> mkTyVarTy rtv
528 tv1 `sameLexeme` tv2 =
529 nameOccName (tyVarName tv1) == nameOccName (tyVarName tv2)
531 extendTvSubst (substSameTyVar tvs replacingTvs) tv replacement
535 %************************************************************************
537 Type-checking instance declarations, pass 2
539 %************************************************************************
542 tcInstDecls2 :: [LTyClDecl Name] -> [InstInfo Name]
544 -- (a) From each class declaration,
545 -- generate any default-method bindings
546 -- (b) From each instance decl
547 -- generate the dfun binding
549 tcInstDecls2 tycl_decls inst_decls
550 = do { -- (a) Default methods from class decls
551 let class_decls = filter (isClassDecl . unLoc) tycl_decls
552 ; dm_binds_s <- mapM tcClassDecl2 class_decls
553 ; let dm_binds = unionManyBags dm_binds_s
555 -- (b) instance declarations
556 ; let dm_ids = collectHsBindsBinders dm_binds
557 -- Add the default method Ids (again)
558 -- See Note [Default methods and instances]
559 ; inst_binds_s <- tcExtendIdEnv dm_ids $
560 mapM tcInstDecl2 inst_decls
563 ; return (dm_binds `unionBags` unionManyBags inst_binds_s) }
565 tcInstDecl2 :: InstInfo Name -> TcM (LHsBinds Id)
566 tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
567 = recoverM (return emptyLHsBinds) $
569 addErrCtxt (instDeclCtxt2 (idType dfun_id)) $
570 tc_inst_decl2 dfun_id ibinds
572 dfun_id = instanceDFunId ispec
573 loc = getSrcSpan dfun_id
576 See Note [Default methods and instances]
577 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
578 The default method Ids are already in the type environment (see Note
579 [Default method Ids and Template Haskell] in TcTyClsDcls), BUT they
580 don't have their InlinePragmas yet. Usually that would not matter,
581 because the simplifier propagates information from binding site to
582 use. But, unusually, when compiling instance decls we *copy* the
583 INLINE pragma from the default method to the method for that
584 particular operation (see Note [INLINE and default methods] below).
586 So right here in tcInstDecl2 we must re-extend the type envt with
587 the default method Ids replete with their INLINE pragmas. Urk.
590 tc_inst_decl2 :: Id -> InstBindings Name -> TcM (LHsBinds Id)
591 -- Returns a binding for the dfun
592 tc_inst_decl2 dfun_id inst_binds
593 = do { let rigid_info = InstSkol
594 inst_ty = idType dfun_id
595 loc = getSrcSpan dfun_id
597 -- Instantiate the instance decl with skolem constants
598 ; (inst_tyvars', dfun_theta', inst_head') <- tcSkolSigType rigid_info inst_ty
599 -- These inst_tyvars' scope over the 'where' part
600 -- Those tyvars are inside the dfun_id's type, which is a bit
601 -- bizarre, but OK so long as you realise it!
603 (clas, inst_tys') = tcSplitDFunHead inst_head'
604 (class_tyvars, sc_theta, sc_sels, op_items) = classBigSig clas
606 -- Instantiate the super-class context with inst_tys
607 sc_theta' = substTheta (zipOpenTvSubst class_tyvars inst_tys') sc_theta
609 -- Create dictionary Ids from the specified instance contexts.
610 ; dfun_ev_vars <- newEvVars dfun_theta'
611 ; self_dict <- newSelfDict clas inst_tys'
612 -- Default-method Ids may be mentioned in synthesised RHSs,
613 -- but they'll already be in the environment.
615 -- Cook up a binding for "self = df d1 .. dn",
616 -- to use in each method binding
617 -- Why? See Note [Subtle interaction of recursion and overlap]
618 ; let self_ev_bind = EvBind self_dict $
619 EvDFunApp dfun_id (mkTyVarTys inst_tyvars') dfun_ev_vars []
620 -- Empty dependencies [], since it only
621 -- depends on "given" things
623 -- Deal with 'SPECIALISE instance' pragmas
624 -- See Note [SPECIALISE instance pragmas]
625 ; spec_info <- tcSpecInstPrags dfun_id inst_binds
627 -- Typecheck the methods
628 ; (meth_ids, meth_binds)
629 <- tcExtendTyVarEnv inst_tyvars' $
630 tcInstanceMethods dfun_id clas inst_tyvars' dfun_ev_vars
631 inst_tys' self_ev_bind spec_info
634 -- Figure out bindings for the superclass context
635 ; let tc_sc = tcSuperClass inst_tyvars' dfun_ev_vars self_ev_bind
636 (sc_eqs, sc_dicts) = splitAt (classSCNEqs clas) sc_theta'
637 ; (sc_dict_ids, sc_binds) <- ASSERT( equalLength sc_sels sc_dicts )
638 ASSERT( all isEqPred sc_eqs )
639 mapAndUnzipM tc_sc (sc_sels `zip` sc_dicts)
642 ; (_eq_sc_binds, sc_eq_vars) <- checkConstraints InstSkol
643 inst_tyvars' dfun_ev_vars $
644 emitWanteds ScOrigin sc_eqs
646 -- Create the result bindings
647 ; let dict_constr = classDataCon clas
648 dict_bind = mkVarBind self_dict dict_rhs
649 dict_rhs = foldl mk_app inst_constr dict_and_meth_ids
650 dict_and_meth_ids = sc_dict_ids ++ meth_ids
651 inst_constr = L loc $ wrapId (mkWpEvVarApps sc_eq_vars
652 <.> mkWpTyApps inst_tys')
653 (dataConWrapId dict_constr)
654 -- We don't produce a binding for the dict_constr; instead we
655 -- rely on the simplifier to unfold this saturated application
656 -- We do this rather than generate an HsCon directly, because
657 -- it means that the special cases (e.g. dictionary with only one
658 -- member) are dealt with by the common MkId.mkDataConWrapId code rather
659 -- than needing to be repeated here.
661 mk_app :: LHsExpr Id -> Id -> LHsExpr Id
662 mk_app fun arg_id = L loc (HsApp fun (L loc (wrapId arg_wrapper arg_id)))
663 arg_wrapper = mkWpEvVarApps dfun_ev_vars <.> mkWpTyApps (mkTyVarTys inst_tyvars')
665 -- Do not inline the dfun; instead give it a magic DFunFunfolding
666 -- See Note [ClassOp/DFun selection]
667 -- See also note [Single-method classes]
668 dfun_id_w_fun = dfun_id
669 `setIdUnfolding` mkDFunUnfolding inst_ty (map Var dict_and_meth_ids)
670 -- Not right for equality superclasses
671 `setInlinePragma` dfunInlinePragma
673 (spec_inst_prags, _) = spec_info
674 main_bind = AbsBinds { abs_tvs = inst_tyvars'
675 , abs_ev_vars = dfun_ev_vars
676 , abs_exports = [(inst_tyvars', dfun_id_w_fun, self_dict,
677 SpecPrags spec_inst_prags)]
678 , abs_ev_binds = emptyTcEvBinds
679 , abs_binds = unitBag dict_bind }
681 ; return (unitBag (L loc main_bind) `unionBags`
682 listToBag meth_binds `unionBags`
686 ------------------------------
687 tcSpecInstPrags :: DFunId -> InstBindings Name
688 -> TcM ([Located TcSpecPrag], PragFun)
689 tcSpecInstPrags _ (NewTypeDerived {})
690 = return ([], \_ -> [])
691 tcSpecInstPrags dfun_id (VanillaInst binds uprags _)
692 = do { spec_inst_prags <- mapM (wrapLocM (tcSpecInst dfun_id)) $
693 filter isSpecInstLSig uprags
694 -- The filter removes the pragmas for methods
695 ; return (spec_inst_prags, mkPragFun uprags binds) }
697 ------------------------------
698 tcSuperClass :: [TyVar] -> [EvVar]
700 -> (Id, PredType) -> TcM (Id, LHsBind Id)
701 -- Build a top level decl like
702 -- sc_op = /\a \d. let this = ... in
705 -- The "this" part is just-in-case (discarded if not used)
706 -- See Note [Recursive superclasses]
707 tcSuperClass tyvars dicts
708 self_ev_bind@(EvBind self_dict _)
710 = do { (ev_binds, wanted, sc_dict)
711 <- newImplication InstSkol tyvars dicts $
712 emitWanted ScOrigin sc_pred
714 ; simplifySuperClass self_dict wanted
715 -- We include self_dict in the 'givens'; the simplifier
716 -- is clever enough to stop sc_pred geting bound by just
717 -- selecting from self_dict!!
720 ; let sc_op_ty = mkForAllTys tyvars $ mkPiTypes dicts (varType sc_dict)
721 sc_op_name = mkDerivedInternalName mkClassOpAuxOcc uniq
723 sc_op_id = mkLocalId sc_op_name sc_op_ty
724 sc_op_bind = VarBind { var_id = sc_op_id, var_inline = False
725 , var_rhs = L noSrcSpan $ wrapId sc_wrapper sc_dict }
726 sc_wrapper = mkWpTyLams tyvars
728 <.> mkWpLet (EvBinds (unitBag self_ev_bind))
731 ; return (sc_op_id, noLoc sc_op_bind) }
734 Note [Recursive superclasses]
735 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
736 See Trac #1470 for why we would *like* to add "self_dict" to the
737 available instances here. But we can't do so because then the superclases
738 get satisfied by selection from self_dict, and that leads to an immediate
739 loop. What we need is to add self_dict to Avails without adding its
740 superclasses, and we currently have no way to do that.
742 Note [SPECIALISE instance pragmas]
743 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
746 instance (Ix a, Ix b) => Ix (a,b) where
747 {-# SPECIALISE instance Ix (Int,Int) #-}
750 We do *not* want to make a specialised version of the dictionary
751 function. Rather, we want specialised versions of each method.
752 Thus we should generate something like this:
754 $dfIx :: (Ix a, Ix x) => Ix (a,b)
755 {- DFUN [$crange, ...] -}
756 $dfIx da db = Ix ($crange da db) (...other methods...)
758 $dfIxPair :: (Ix a, Ix x) => Ix (a,b)
759 {- DFUN [$crangePair, ...] -}
760 $dfIxPair = Ix ($crangePair da db) (...other methods...)
762 $crange :: (Ix a, Ix b) -> ((a,b),(a,b)) -> [(a,b)]
763 {-# SPECIALISE $crange :: ((Int,Int),(Int,Int)) -> [(Int,Int)] #-}
764 $crange da db = <blah>
766 {-# RULE range ($dfIx da db) = $crange da db #-}
770 * The RULE is unaffected by the specialisation. We don't want to
771 specialise $dfIx, because then it would need a specialised RULE
772 which is a pain. The single RULE works fine at all specialisations.
773 See Note [How instance declarations are translated] above
775 * Instead, we want to specialise the *method*, $crange
777 In practice, rather than faking up a SPECIALISE pragama for each
778 method (which is painful, since we'd have to figure out its
779 specialised type), we call tcSpecPrag *as if* were going to specialise
780 $dfIx -- you can see that in the call to tcSpecInst. That generates a
781 SpecPrag which, as it turns out, can be used unchanged for each method.
782 The "it turns out" bit is delicate, but it works fine!
785 tcSpecInst :: Id -> Sig Name -> TcM TcSpecPrag
786 tcSpecInst dfun_id prag@(SpecInstSig hs_ty)
787 = addErrCtxt (spec_ctxt prag) $
788 do { let name = idName dfun_id
789 ; (tyvars, theta, tau) <- tcHsInstHead hs_ty
790 ; let spec_ty = mkSigmaTy tyvars theta tau
791 ; co_fn <- tcSubType (SpecPragOrigin name) (SigSkol SpecInstCtxt)
792 (idType dfun_id) spec_ty
793 ; return (SpecPrag dfun_id co_fn defaultInlinePragma) }
795 spec_ctxt prag = hang (ptext (sLit "In the SPECIALISE pragma")) 2 (ppr prag)
797 tcSpecInst _ _ = panic "tcSpecInst"
800 %************************************************************************
802 Type-checking an instance method
804 %************************************************************************
807 - Make the method bindings, as a [(NonRec, HsBinds)], one per method
808 - Remembering to use fresh Name (the instance method Name) as the binder
809 - Bring the instance method Ids into scope, for the benefit of tcInstSig
810 - Use sig_fn mapping instance method Name -> instance tyvars
812 - Use tcValBinds to do the checking
815 tcInstanceMethods :: DFunId -> Class -> [TcTyVar]
818 -> EvBind -- "This" and its binding
819 -> ([Located TcSpecPrag], PragFun)
822 -> TcM ([Id], [LHsBind Id])
823 -- The returned inst_meth_ids all have types starting
824 -- forall tvs. theta => ...
825 tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
826 self_dict_ev (spec_inst_prags, prag_fn)
827 op_items (VanillaInst binds _ standalone_deriv)
828 = mapAndUnzipM tc_item op_items
830 ----------------------
831 tc_item :: (Id, DefMeth) -> TcM (Id, LHsBind Id)
832 tc_item (sel_id, dm_info)
833 = case findMethodBind (idName sel_id) binds of
834 Just user_bind -> tc_body sel_id standalone_deriv user_bind
835 Nothing -> tc_default sel_id dm_info
837 ----------------------
838 tc_body :: Id -> Bool -> LHsBind Name -> TcM (TcId, LHsBind Id)
839 tc_body sel_id generated_code rn_bind
840 = add_meth_ctxt sel_id generated_code rn_bind $
841 do { (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars
843 ; let prags = prag_fn (idName sel_id)
844 ; meth_id1 <- addInlinePrags meth_id prags
845 ; spec_prags <- tcSpecPrags meth_id1 prags
846 ; bind <- tcInstanceMethodBody InstSkol
847 tyvars dfun_ev_vars mb_dict_ev
848 meth_id1 local_meth_id meth_sig_fn
849 (mk_meth_spec_prags meth_id1 spec_prags)
851 ; return (meth_id1, bind) }
853 ----------------------
854 tc_default :: Id -> DefMeth -> TcM (TcId, LHsBind Id)
855 tc_default sel_id GenDefMeth -- Derivable type classes stuff
856 = do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id
857 ; tc_body sel_id False {- Not generated code? -} meth_bind }
859 tc_default sel_id NoDefMeth -- No default method at all
860 = do { warnMissingMethod sel_id
861 ; (meth_id, _) <- mkMethIds clas tyvars dfun_ev_vars
863 ; return (meth_id, mkVarBind meth_id $
864 mkLHsWrap lam_wrapper error_rhs) }
866 error_rhs = L loc $ HsApp error_fun error_msg
867 error_fun = L loc $ wrapId (WpTyApp meth_tau) nO_METHOD_BINDING_ERROR_ID
868 error_msg = L loc (HsLit (HsStringPrim (mkFastString error_string)))
869 meth_tau = funResultTy (applyTys (idType sel_id) inst_tys)
870 error_string = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
871 lam_wrapper = mkWpTyLams tyvars <.> mkWpLams dfun_ev_vars
873 tc_default sel_id (DefMeth dm_name) -- A polymorphic default method
874 = do { -- Build the typechecked version directly,
875 -- without calling typecheck_method;
876 -- see Note [Default methods in instances]
877 -- Generate /\as.\ds. let this = df as ds
878 -- in $dm inst_tys this
879 -- The 'let' is necessary only because HsSyn doesn't allow
880 -- you to apply a function to a dictionary *expression*.
882 ; (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars
884 ; dm_id <- tcLookupId dm_name
885 ; let dm_inline_prag = idInlinePragma dm_id
886 EvBind self_dict _ = self_dict_ev
887 rhs = HsWrap (mkWpEvVarApps [self_dict] <.> mkWpTyApps inst_tys) $
890 meth_bind = L loc $ VarBind { var_id = local_meth_id
891 , var_rhs = L loc rhs
892 , var_inline = False }
893 meth_id1 = meth_id `setInlinePragma` dm_inline_prag
894 -- Copy the inline pragma (if any) from the default
895 -- method to this version. Note [INLINE and default methods]
897 bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars
898 , abs_exports = [( tyvars, meth_id1, local_meth_id
899 , mk_meth_spec_prags meth_id1 [])]
900 , abs_ev_binds = EvBinds (unitBag self_dict_ev)
901 , abs_binds = unitBag meth_bind }
902 -- Default methods in an instance declaration can't have their own
903 -- INLINE or SPECIALISE pragmas. It'd be possible to allow them, but
904 -- currently they are rejected with
905 -- "INLINE pragma lacks an accompanying binding"
907 ; return (meth_id1, L loc bind) }
909 ----------------------
910 mk_meth_spec_prags :: Id -> [LTcSpecPrag] -> TcSpecPrags
911 -- Adapt the SPECIALISE pragmas to work for this method Id
912 -- There are two sources:
913 -- * spec_inst_prags: {-# SPECIALISE instance :: <blah> #-}
914 -- These ones have the dfun inside, but [perhaps surprisingly]
915 -- the correct wrapper
916 -- * spec_prags_for_me: {-# SPECIALISE op :: <blah> #-}
917 mk_meth_spec_prags meth_id spec_prags_for_me
918 = SpecPrags (spec_prags_for_me ++
919 [ L loc (SpecPrag meth_id wrap inl)
920 | L loc (SpecPrag _ wrap inl) <- spec_inst_prags])
922 loc = getSrcSpan dfun_id
923 meth_sig_fn _ = Just ([],loc) -- The 'Just' says "yes, there's a type sig"
924 -- But there are no scoped type variables from local_method_id
925 -- Only the ones from the instance decl itself, which are already
926 -- in scope. Example:
927 -- class C a where { op :: forall b. Eq b => ... }
928 -- instance C [c] where { op = <rhs> }
929 -- In <rhs>, 'c' is scope but 'b' is not!
931 mb_dict_ev = if null tyvars then Nothing else Just self_dict_ev
932 -- Only need the self_dict stuff if there are type
933 -- variables involved; otherwise overlap is not possible
934 -- See Note [Subtle interaction of recursion and overlap]
937 -- For instance decls that come from standalone deriving clauses
938 -- we want to print out the full source code if there's an error
939 -- because otherwise the user won't see the code at all
940 add_meth_ctxt sel_id generated_code rn_bind thing
941 | generated_code = addLandmarkErrCtxt (derivBindCtxt sel_id clas inst_tys rn_bind) thing
945 tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
946 _ _ op_items (NewTypeDerived coi _)
949 -- class Show b => Foo a b where
951 -- newtype N a = MkN (Tree [a])
952 -- deriving instance (Show p, Foo Int p) => Foo Int (N p)
953 -- -- NB: standalone deriving clause means
954 -- -- that the contex is user-specified
955 -- Hence op :: forall a b. Foo a b => a -> b -> b
957 -- We're going to make an instance like
958 -- instance (Show p, Foo Int p) => Foo Int (N p)
961 -- $copT :: forall p. (Show p, Foo Int p) => Int -> N p -> N p
962 -- $copT p (d1:Show p) (d2:Foo Int p)
963 -- = op Int (Tree [p]) rep_d |> op_co
965 -- rep_d :: Foo Int (Tree [p]) = ...d1...d2...
966 -- op_co :: (Int -> Tree [p] -> Tree [p]) ~ (Int -> T p -> T p)
967 -- We get op_co by substituting [Int/a] and [co/b] in type for op
968 -- where co : [p] ~ T p
970 -- Notice that the dictionary bindings "..d1..d2.." must be generated
971 -- by the constraint solver, since the <context> may be
974 = do { rep_d_stuff <- checkConstraints InstSkol tyvars dfun_ev_vars $
975 emitWanted ScOrigin rep_pred
977 ; mapAndUnzipM (tc_item rep_d_stuff) op_items }
979 loc = getSrcSpan dfun_id
981 inst_tvs = fst (tcSplitForAllTys (idType dfun_id))
982 Just (init_inst_tys, _) = snocView inst_tys
983 rep_ty = fst (coercionKind co) -- [p]
984 rep_pred = mkClassPred clas (init_inst_tys ++ [rep_ty])
987 co = substTyWith inst_tvs (mkTyVarTys tyvars) $
988 case coi of { IdCo ty -> ty ;
989 ACo co -> mkSymCoercion co }
992 tc_item :: (TcEvBinds, EvVar) -> (Id, DefMeth) -> TcM (TcId, LHsBind TcId)
993 tc_item (rep_ev_binds, rep_d) (sel_id, _)
994 = do { (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars
997 ; let meth_rhs = wrapId (mk_op_wrapper sel_id rep_d) sel_id
998 meth_bind = VarBind { var_id = local_meth_id
999 , var_rhs = L loc meth_rhs
1000 , var_inline = False }
1002 bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars
1003 , abs_exports = [(tyvars, meth_id,
1004 local_meth_id, noSpecPrags)]
1005 , abs_ev_binds = rep_ev_binds
1006 , abs_binds = unitBag $ L loc meth_bind }
1008 ; return (meth_id, L loc bind) }
1011 mk_op_wrapper :: Id -> EvVar -> HsWrapper
1012 mk_op_wrapper sel_id rep_d
1013 = WpCast (substTyWith sel_tvs (init_inst_tys ++ [co]) local_meth_ty)
1014 <.> WpEvApp (EvId rep_d)
1015 <.> mkWpTyApps (init_inst_tys ++ [rep_ty])
1017 (sel_tvs, sel_rho) = tcSplitForAllTys (idType sel_id)
1018 (_, local_meth_ty) = tcSplitPredFunTy_maybe sel_rho
1019 `orElse` pprPanic "tcInstanceMethods" (ppr sel_id)
1021 ----------------------
1022 mkMethIds :: Class -> [TcTyVar] -> [EvVar] -> [TcType] -> Id -> TcM (TcId, TcId)
1023 mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id
1024 = do { uniq <- newUnique
1025 ; let meth_name = mkDerivedInternalName mkClassOpAuxOcc uniq sel_name
1026 ; local_meth_name <- newLocalName sel_name
1027 -- Base the local_meth_name on the selector name, becuase
1028 -- type errors from tcInstanceMethodBody come from here
1030 ; let meth_id = mkLocalId meth_name meth_ty
1031 local_meth_id = mkLocalId local_meth_name local_meth_ty
1032 ; return (meth_id, local_meth_id) }
1034 local_meth_ty = instantiateMethod clas sel_id inst_tys
1035 meth_ty = mkForAllTys tyvars $ mkPiTypes dfun_ev_vars local_meth_ty
1036 sel_name = idName sel_id
1038 ----------------------
1039 wrapId :: HsWrapper -> id -> HsExpr id
1040 wrapId wrapper id = mkHsWrap wrapper (HsVar id)
1042 derivBindCtxt :: Id -> Class -> [Type ] -> LHsBind Name -> SDoc
1043 derivBindCtxt sel_id clas tys _bind
1044 = vcat [ ptext (sLit "When typechecking the code for ") <+> quotes (ppr sel_id)
1045 , nest 2 (ptext (sLit "in a standalone derived instance for")
1046 <+> quotes (pprClassPred clas tys) <> colon)
1047 , nest 2 $ ptext (sLit "To see the code I am typechecking, use -ddump-deriv") ]
1050 -- , nest 2 $ pprSetDepth AllTheWay $ ppr bind ]
1052 warnMissingMethod :: Id -> TcM ()
1053 warnMissingMethod sel_id
1054 = do { warn <- doptM Opt_WarnMissingMethods
1055 ; warnTc (warn -- Warn only if -fwarn-missing-methods
1056 && not (startsWithUnderscore (getOccName sel_id)))
1057 -- Don't warn about _foo methods
1058 (ptext (sLit "No explicit method nor default method for")
1059 <+> quotes (ppr sel_id)) }
1062 Note [Export helper functions]
1063 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1064 We arrange to export the "helper functions" of an instance declaration,
1065 so that they are not subject to preInlineUnconditionally, even if their
1066 RHS is trivial. Reason: they are mentioned in the DFunUnfolding of
1067 the dict fun as Ids, not as CoreExprs, so we can't substitute a
1068 non-variable for them.
1070 We could change this by making DFunUnfoldings have CoreExprs, but it
1071 seems a bit simpler this way.
1073 Note [Default methods in instances]
1074 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1081 instance Baz Int Int
1083 From the class decl we get
1085 $dmfoo :: forall v x. Baz v x => x -> x
1088 Notice that the type is ambiguous. That's fine, though. The instance
1091 $dBazIntInt = MkBaz fooIntInt
1092 fooIntInt = $dmfoo Int Int $dBazIntInt
1094 BUT this does mean we must generate the dictionary translation of
1095 fooIntInt directly, rather than generating source-code and
1096 type-checking it. That was the bug in Trac #1061. In any case it's
1097 less work to generate the translated version!
1099 Note [INLINE and default methods]
1100 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1101 Default methods need special case. They are supposed to behave rather like
1102 macros. For exmample
1105 op1, op2 :: Bool -> a -> a
1108 op1 b x = op2 (not b) x
1110 instance Foo Int where
1111 -- op1 via default method
1114 The instance declaration should behave
1116 just as if 'op1' had been defined with the
1117 code, and INLINE pragma, from its original
1120 That is, just as if you'd written
1122 instance Foo Int where
1126 op1 b x = op2 (not b) x
1128 So for the above example we generate:
1131 {-# INLINE $dmop1 #-}
1132 -- $dmop1 has an InlineCompulsory unfolding
1133 $dmop1 d b x = op2 d (not b) x
1135 $fFooInt = MkD $cop1 $cop2
1137 {-# INLINE $cop1 #-}
1138 $cop1 = $dmop1 $fFooInt
1144 * We *copy* any INLINE pragma from the default method $dmop1 to the
1145 instance $cop1. Otherwise we'll just inline the former in the
1146 latter and stop, which isn't what the user expected
1148 * Regardless of its pragma, we give the default method an
1149 unfolding with an InlineCompulsory source. That means
1150 that it'll be inlined at every use site, notably in
1151 each instance declaration, such as $cop1. This inlining
1152 must happen even though
1153 a) $dmop1 is not saturated in $cop1
1154 b) $cop1 itself has an INLINE pragma
1156 It's vital that $dmop1 *is* inlined in this way, to allow the mutual
1157 recursion between $fooInt and $cop1 to be broken
1159 * To communicate the need for an InlineCompulsory to the desugarer
1160 (which makes the Unfoldings), we use the IsDefaultMethod constructor
1164 %************************************************************************
1166 \subsection{Error messages}
1168 %************************************************************************
1171 instDeclCtxt1 :: LHsType Name -> SDoc
1172 instDeclCtxt1 hs_inst_ty
1173 = inst_decl_ctxt (case unLoc hs_inst_ty of
1174 HsForAllTy _ _ _ (L _ (HsPredTy pred)) -> ppr pred
1175 HsPredTy pred -> ppr pred
1176 _ -> ppr hs_inst_ty) -- Don't expect this
1177 instDeclCtxt2 :: Type -> SDoc
1178 instDeclCtxt2 dfun_ty
1179 = inst_decl_ctxt (ppr (mkClassPred cls tys))
1181 (_,cls,tys) = tcSplitDFunTy dfun_ty
1183 inst_decl_ctxt :: SDoc -> SDoc
1184 inst_decl_ctxt doc = ptext (sLit "In the instance declaration for") <+> quotes doc
1186 atInstCtxt :: Name -> SDoc
1187 atInstCtxt name = ptext (sLit "In the associated type instance for") <+>
1190 mustBeVarArgErr :: Type -> SDoc
1191 mustBeVarArgErr ty =
1192 sep [ ptext (sLit "Arguments that do not correspond to a class parameter") <+>
1193 ptext (sLit "must be variables")
1194 , ptext (sLit "Instead of a variable, found") <+> ppr ty
1197 wrongATArgErr :: Type -> Type -> SDoc
1198 wrongATArgErr ty instTy =
1199 sep [ ptext (sLit "Type indexes must match class instance head")
1200 , ptext (sLit "Found") <+> quotes (ppr ty)
1201 <+> ptext (sLit "but expected") <+> quotes (ppr instTy)