2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
6 TcInstDecls: Typechecking instance declarations
9 module TcInstDcls ( tcInstDecls1, tcInstDecls2 ) where
24 import RnSource ( addTcgDUs )
25 import TcSimplify( simplifySuperClass )
34 import VarSet ( emptyVarSet )
35 import CoreUtils ( mkPiTypes )
36 import CoreUnfold ( mkDFunUnfolding )
37 import CoreSyn ( Expr(Var) )
50 import Maybes ( orElse )
55 #include "HsVersions.h"
58 Typechecking instance declarations is done in two passes. The first
59 pass, made by @tcInstDecls1@, collects information to be used in the
62 This pre-processed info includes the as-yet-unprocessed bindings
63 inside the instance declaration. These are type-checked in the second
64 pass, when the class-instance envs and GVE contain all the info from
65 all the instance and value decls. Indeed that's the reason we need
66 two passes over the instance decls.
69 Note [How instance declarations are translated]
70 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
71 Here is how we translation instance declarations into Core
75 op1, op2 :: Ix b => a -> b -> b
79 {-# INLINE [2] op1 #-}
83 op1,op2 :: forall a. C a => forall b. Ix b => a -> b -> b
87 -- Default methods get the 'self' dictionary as argument
88 -- so they can call other methods at the same type
89 -- Default methods get the same type as their method selector
90 $dmop2 :: forall a. C a => forall b. Ix b => a -> b -> b
91 $dmop2 = /\a. \(d:C a). /\b. \(d2: Ix b). <dm-rhs>
92 -- NB: type variables 'a' and 'b' are *both* in scope in <dm-rhs>
93 -- Note [Tricky type variable scoping]
95 -- A top-level definition for each instance method
96 -- Here op1_i, op2_i are the "instance method Ids"
97 -- The INLINE pragma comes from the user pragma
98 {-# INLINE [2] op1_i #-} -- From the instance decl bindings
99 op1_i, op2_i :: forall a. C a => forall b. Ix b => [a] -> b -> b
100 op1_i = /\a. \(d:C a).
103 -- Note [Subtle interaction of recursion and overlap]
105 local_op1 :: forall b. Ix b => [a] -> b -> b
107 -- Source code; run the type checker on this
108 -- NB: Type variable 'a' (but not 'b') is in scope in <rhs>
109 -- Note [Tricky type variable scoping]
113 op2_i = /\a \d:C a. $dmop2 [a] (df_i a d)
115 -- The dictionary function itself
116 {-# NOINLINE CONLIKE df_i #-} -- Never inline dictionary functions
117 df_i :: forall a. C a -> C [a]
118 df_i = /\a. \d:C a. MkC (op1_i a d) (op2_i a d)
119 -- But see Note [Default methods in instances]
120 -- We can't apply the type checker to the default-method call
122 -- Use a RULE to short-circuit applications of the class ops
123 {-# RULE "op1@C[a]" forall a, d:C a.
124 op1 [a] (df_i d) = op1_i a d #-}
126 Note [Instances and loop breakers]
127 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
128 * Note that df_i may be mutually recursive with both op1_i and op2_i.
129 It's crucial that df_i is not chosen as the loop breaker, even
130 though op1_i has a (user-specified) INLINE pragma.
132 * Instead the idea is to inline df_i into op1_i, which may then select
133 methods from the MkC record, and thereby break the recursion with
134 df_i, leaving a *self*-recurisve op1_i. (If op1_i doesn't call op at
135 the same type, it won't mention df_i, so there won't be recursion in
138 * If op1_i is marked INLINE by the user there's a danger that we won't
139 inline df_i in it, and that in turn means that (since it'll be a
140 loop-breaker because df_i isn't), op1_i will ironically never be
141 inlined. But this is OK: the recursion breaking happens by way of
142 a RULE (the magic ClassOp rule above), and RULES work inside InlineRule
143 unfoldings. See Note [RULEs enabled in SimplGently] in SimplUtils
145 Note [ClassOp/DFun selection]
146 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
147 One thing we see a lot is stuff like
149 where 'op2' is a ClassOp and 'df' is DFun. Now, we could inline *both*
150 'op2' and 'df' to get
151 case (MkD ($cop1 d1 d2) ($cop2 d1 d2) ... of
152 MkD _ op2 _ _ _ -> op2
153 And that will reduce to ($cop2 d1 d2) which is what we wanted.
155 But it's tricky to make this work in practice, because it requires us to
156 inline both 'op2' and 'df'. But neither is keen to inline without having
157 seen the other's result; and it's very easy to get code bloat (from the
158 big intermediate) if you inline a bit too much.
160 Instead we use a cunning trick.
161 * We arrange that 'df' and 'op2' NEVER inline.
163 * We arrange that 'df' is ALWAYS defined in the sylised form
164 df d1 d2 = MkD ($cop1 d1 d2) ($cop2 d1 d2) ...
166 * We give 'df' a magical unfolding (DFunUnfolding [$cop1, $cop2, ..])
167 that lists its methods.
169 * We make CoreUnfold.exprIsConApp_maybe spot a DFunUnfolding and return
170 a suitable constructor application -- inlining df "on the fly" as it
173 * We give the ClassOp 'op2' a BuiltinRule that extracts the right piece
174 iff its argument satisfies exprIsConApp_maybe. This is done in
177 * We make 'df' CONLIKE, so that shared uses stil match; eg
179 in ...(op2 d)...(op1 d)...
181 Note [Single-method classes]
182 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
183 If the class has just one method (or, more accurately, just one element
184 of {superclasses + methods}), then we still use the *same* strategy
186 class C a where op :: a -> a
187 instance C a => C [a] where op = <blah>
189 We translate the class decl into a newtype, which just gives
192 axiom Co:C a :: C a ~ (a->a)
194 op :: forall a. C a -> (a -> a)
195 op a d = d |> (Co:C a)
197 MkC :: forall a. (a->a) -> C a
198 MkC = /\a.\op. op |> (sym Co:C a)
200 df :: forall a. C a => C [a]
201 {-# NOINLINE df DFun[ $cop_list ] #-}
202 df = /\a. \d. MkC ($cop_list a d)
204 $cop_list :: forall a. C a => [a] -> [a]
207 The "constructor" MkC expands to a cast, as does the class-op selector.
208 The RULE works just like for multi-field dictionaries:
210 * (df a d) returns (Just (MkC,..,[$cop_list a d]))
211 to exprIsConApp_Maybe
213 * The RULE for op picks the right result
215 This is a bit of a hack, because (df a d) isn't *really* a constructor
216 application. But it works just fine in this case, exprIsConApp_maybe
217 is otherwise used only when we hit a case expression which will have
218 a real data constructor in it.
220 The biggest reason for doing it this way, apart from uniformity, is
221 that we want to be very careful when we have
222 instance C a => C [a] where
225 then we'll get an INLINE pragma on $cop_list but it's important that
226 $cop_list only inlines when it's applied to *two* arguments (the
227 dictionary and the list argument
229 The danger is that we'll get something like
230 op_list :: C a => [a] -> [a]
231 op_list = /\a.\d. $cop_list a d
232 and then we'll eta expand, and then we'll inline TOO EARLY. This happened in
233 Trac #3772 and I spent far too long fiddling around trying to fix it.
234 Look at the test for Trac #3772.
236 (Note: re-reading the above, I can't see how using the
237 uniform story solves the problem.)
239 Note [Subtle interaction of recursion and overlap]
240 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
242 class C a where { op1,op2 :: a -> a }
243 instance C a => C [a] where
244 op1 x = op2 x ++ op2 x
246 instance C [Int] where
249 When type-checking the C [a] instance, we need a C [a] dictionary (for
250 the call of op2). If we look up in the instance environment, we find
251 an overlap. And in *general* the right thing is to complain (see Note
252 [Overlapping instances] in InstEnv). But in *this* case it's wrong to
253 complain, because we just want to delegate to the op2 of this same
256 Why is this justified? Because we generate a (C [a]) constraint in
257 a context in which 'a' cannot be instantiated to anything that matches
258 other overlapping instances, or else we would not be excecuting this
259 version of op1 in the first place.
261 It might even be a bit disguised:
263 nullFail :: C [a] => [a] -> [a]
264 nullFail x = op2 x ++ op2 x
266 instance C a => C [a] where
269 Precisely this is used in package 'regex-base', module Context.hs.
270 See the overlapping instances for RegexContext, and the fact that they
271 call 'nullFail' just like the example above. The DoCon package also
272 does the same thing; it shows up in module Fraction.hs
274 Conclusion: when typechecking the methods in a C [a] instance, we want
275 to have C [a] available. That is why we have the strange local
276 definition for 'this' in the definition of op1_i in the example above.
277 We can typecheck the defintion of local_op1, and when doing tcSimplifyCheck
278 we supply 'this' as a given dictionary. Only needed, though, if there
279 are some type variables involved; otherwise there can be no overlap and
282 Note [Tricky type variable scoping]
283 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
286 op1, op2 :: Ix b => a -> b -> b
289 instance C a => C [a]
290 {-# INLINE [2] op1 #-}
293 note that 'a' and 'b' are *both* in scope in <dm-rhs>, but only 'a' is
294 in scope in <rhs>. In particular, we must make sure that 'b' is in
295 scope when typechecking <dm-rhs>. This is achieved by subFunTys,
296 which brings appropriate tyvars into scope. This happens for both
297 <dm-rhs> and for <rhs>, but that doesn't matter: the *renamer* will have
298 complained if 'b' is mentioned in <rhs>.
302 %************************************************************************
304 \subsection{Extracting instance decls}
306 %************************************************************************
308 Gather up the instance declarations from their various sources
311 tcInstDecls1 -- Deal with both source-code and imported instance decls
312 :: [LTyClDecl Name] -- For deriving stuff
313 -> [LInstDecl Name] -- Source code instance decls
314 -> [LDerivDecl Name] -- Source code stand-alone deriving decls
315 -> TcM (TcGblEnv, -- The full inst env
316 [InstInfo Name], -- Source-code instance decls to process;
317 -- contains all dfuns for this module
318 HsValBinds Name) -- Supporting bindings for derived instances
320 tcInstDecls1 tycl_decls inst_decls deriv_decls
322 do { -- Stop if addInstInfos etc discovers any errors
323 -- (they recover, so that we get more than one error each
326 -- (1) Do class and family instance declarations
327 ; idx_tycons <- mapAndRecoverM (tcFamInstDecl TopLevel) $
328 filter (isFamInstDecl . unLoc) tycl_decls
329 ; local_info_tycons <- mapAndRecoverM tcLocalInstDecl1 inst_decls
332 at_tycons_s) = unzip local_info_tycons
333 ; at_idx_tycons = concat at_tycons_s ++ idx_tycons
334 ; clas_decls = filter (isClassDecl.unLoc) tycl_decls
335 ; implicit_things = concatMap implicitTyThings at_idx_tycons
336 ; aux_binds = mkRecSelBinds at_idx_tycons
339 -- (2) Add the tycons of indexed types and their implicit
340 -- tythings to the global environment
341 ; tcExtendGlobalEnv (at_idx_tycons ++ implicit_things) $ do {
343 -- (3) Instances from generic class declarations
344 ; generic_inst_info <- getGenericInstances clas_decls
346 -- Next, construct the instance environment so far, consisting
348 -- (a) local instance decls
349 -- (b) generic instances
350 -- (c) local family instance decls
351 ; addInsts local_info $
352 addInsts generic_inst_info $
353 addFamInsts at_idx_tycons $ do {
355 -- (4) Compute instances from "deriving" clauses;
356 -- This stuff computes a context for the derived instance
357 -- decl, so it needs to know about all the instances possible
358 -- NB: class instance declarations can contain derivings as
359 -- part of associated data type declarations
360 failIfErrsM -- If the addInsts stuff gave any errors, don't
361 -- try the deriving stuff, becuase that may give
363 ; (deriv_inst_info, deriv_binds, deriv_dus)
364 <- tcDeriving tycl_decls inst_decls deriv_decls
365 ; gbl_env <- addInsts deriv_inst_info getGblEnv
366 ; return ( addTcgDUs gbl_env deriv_dus,
367 generic_inst_info ++ deriv_inst_info ++ local_info,
368 aux_binds `plusHsValBinds` deriv_binds)
371 addInsts :: [InstInfo Name] -> TcM a -> TcM a
372 addInsts infos thing_inside
373 = tcExtendLocalInstEnv (map iSpec infos) thing_inside
375 addFamInsts :: [TyThing] -> TcM a -> TcM a
376 addFamInsts tycons thing_inside
377 = tcExtendLocalFamInstEnv (map mkLocalFamInstTyThing tycons) thing_inside
379 mkLocalFamInstTyThing (ATyCon tycon) = mkLocalFamInst tycon
380 mkLocalFamInstTyThing tything = pprPanic "TcInstDcls.addFamInsts"
385 tcLocalInstDecl1 :: LInstDecl Name
386 -> TcM (InstInfo Name, [TyThing])
387 -- A source-file instance declaration
388 -- Type-check all the stuff before the "where"
390 -- We check for respectable instance type, and context
391 tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats))
393 addErrCtxt (instDeclCtxt1 poly_ty) $
395 do { is_boot <- tcIsHsBoot
396 ; checkTc (not is_boot || (isEmptyLHsBinds binds && null uprags))
399 ; (tyvars, theta, tau) <- tcHsInstHead poly_ty
401 -- Now, check the validity of the instance.
402 ; (clas, inst_tys) <- checkValidInstance poly_ty tyvars theta tau
404 -- Next, process any associated types.
405 ; idx_tycons <- recoverM (return []) $
406 do { idx_tycons <- checkNoErrs $
407 mapAndRecoverM (tcFamInstDecl NotTopLevel) ats
408 ; checkValidAndMissingATs clas (tyvars, inst_tys)
410 ; return idx_tycons }
412 -- Finally, construct the Core representation of the instance.
413 -- (This no longer includes the associated types.)
414 ; dfun_name <- newDFunName clas inst_tys (getLoc poly_ty)
415 -- Dfun location is that of instance *header*
416 ; overlap_flag <- getOverlapFlag
417 ; let (eq_theta,dict_theta) = partition isEqPred theta
418 theta' = eq_theta ++ dict_theta
419 dfun = mkDictFunId dfun_name tyvars theta' clas inst_tys
420 ispec = mkLocalInstance dfun overlap_flag
422 ; return (InstInfo { iSpec = ispec,
423 iBinds = VanillaInst binds uprags False },
427 -- We pass in the source form and the type checked form of the ATs. We
428 -- really need the source form only to be able to produce more informative
430 checkValidAndMissingATs :: Class
431 -> ([TyVar], [TcType]) -- instance types
432 -> [(LTyClDecl Name, -- source form of AT
433 TyThing)] -- Core form of AT
435 checkValidAndMissingATs clas inst_tys ats
436 = do { -- Issue a warning for each class AT that is not defined in this
438 ; let class_ats = map tyConName (classATs clas)
439 defined_ats = listToNameSet . map (tcdName.unLoc.fst) $ ats
440 omitted = filterOut (`elemNameSet` defined_ats) class_ats
441 ; warn <- doptM Opt_WarnMissingMethods
442 ; mapM_ (warnTc warn . omittedATWarn) omitted
444 -- Ensure that all AT indexes that correspond to class parameters
445 -- coincide with the types in the instance head. All remaining
446 -- AT arguments must be variables. Also raise an error for any
447 -- type instances that are not associated with this class.
448 ; mapM_ (checkIndexes clas inst_tys) ats
451 checkIndexes clas inst_tys (hsAT, ATyCon tycon)
452 -- !!!TODO: check that this does the Right Thing for indexed synonyms, too!
453 = checkIndexes' clas inst_tys hsAT
455 snd . fromJust . tyConFamInst_maybe $ tycon)
456 checkIndexes _ _ _ = panic "checkIndexes"
458 checkIndexes' clas (instTvs, instTys) hsAT (atTvs, atTys)
459 = let atName = tcdName . unLoc $ hsAT
461 setSrcSpan (getLoc hsAT) $
462 addErrCtxt (atInstCtxt atName) $
463 case find ((atName ==) . tyConName) (classATs clas) of
464 Nothing -> addErrTc $ badATErr clas atName -- not in this class
466 -- The following is tricky! We need to deal with three
467 -- complications: (1) The AT possibly only uses a subset of
468 -- the class parameters as indexes and those it uses may be in
469 -- a different order; (2) the AT may have extra arguments,
470 -- which must be type variables; and (3) variables in AT and
471 -- instance head will be different `Name's even if their
472 -- source lexemes are identical.
474 -- e.g. class C a b c where
475 -- data D b a :: * -> * -- NB (1) b a, omits c
476 -- instance C [x] Bool Char where
477 -- data D Bool [x] v = MkD x [v] -- NB (2) v
478 -- -- NB (3) the x in 'instance C...' have differnt
479 -- -- Names to x's in 'data D...'
481 -- Re (1), `poss' contains a permutation vector to extract the
482 -- class parameters in the right order.
484 -- Re (2), we wrap the (permuted) class parameters in a Maybe
485 -- type and use Nothing for any extra AT arguments. (First
486 -- equation of `checkIndex' below.)
488 -- Re (3), we replace any type variable in the AT parameters
489 -- that has the same source lexeme as some variable in the
490 -- instance types with the instance type variable sharing its
494 -- For *associated* type families, gives the position
495 -- of that 'TyVar' in the class argument list (0-indexed)
496 -- e.g. class C a b c where { type F c a :: *->* }
497 -- Then we get Just [2,0]
498 poss = catMaybes [ tv `elemIndex` classTyVars clas
499 | tv <- tyConTyVars atycon]
500 -- We will get Nothings for the "extra" type
501 -- variables in an associated data type
502 -- e.g. class C a where { data D a :: *->* }
503 -- here D gets arity 2 and has two tyvars
505 relevantInstTys = map (instTys !!) poss
506 instArgs = map Just relevantInstTys ++
507 repeat Nothing -- extra arguments
508 renaming = substSameTyVar atTvs instTvs
510 zipWithM_ checkIndex (substTys renaming atTys) instArgs
512 checkIndex ty Nothing
513 | isTyVarTy ty = return ()
514 | otherwise = addErrTc $ mustBeVarArgErr ty
515 checkIndex ty (Just instTy)
516 | ty `tcEqType` instTy = return ()
517 | otherwise = addErrTc $ wrongATArgErr ty instTy
519 listToNameSet = addListToNameSet emptyNameSet
521 substSameTyVar [] _ = emptyTvSubst
522 substSameTyVar (tv:tvs) replacingTvs =
523 let replacement = case find (tv `sameLexeme`) replacingTvs of
524 Nothing -> mkTyVarTy tv
525 Just rtv -> mkTyVarTy rtv
527 tv1 `sameLexeme` tv2 =
528 nameOccName (tyVarName tv1) == nameOccName (tyVarName tv2)
530 extendTvSubst (substSameTyVar tvs replacingTvs) tv replacement
534 %************************************************************************
536 Type-checking instance declarations, pass 2
538 %************************************************************************
541 tcInstDecls2 :: [LTyClDecl Name] -> [InstInfo Name]
543 -- (a) From each class declaration,
544 -- generate any default-method bindings
545 -- (b) From each instance decl
546 -- generate the dfun binding
548 tcInstDecls2 tycl_decls inst_decls
549 = do { -- (a) Default methods from class decls
550 let class_decls = filter (isClassDecl . unLoc) tycl_decls
551 ; dm_binds_s <- mapM tcClassDecl2 class_decls
552 ; let dm_binds = unionManyBags dm_binds_s
554 -- (b) instance declarations
555 ; let dm_ids = collectHsBindsBinders dm_binds
556 -- Add the default method Ids (again)
557 -- See Note [Default methods and instances]
558 ; inst_binds_s <- tcExtendIdEnv dm_ids $
559 mapM tcInstDecl2 inst_decls
562 ; return (dm_binds `unionBags` unionManyBags inst_binds_s) }
564 tcInstDecl2 :: InstInfo Name -> TcM (LHsBinds Id)
565 tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
566 = recoverM (return emptyLHsBinds) $
568 addErrCtxt (instDeclCtxt2 (idType dfun_id)) $
569 tc_inst_decl2 dfun_id ibinds
571 dfun_id = instanceDFunId ispec
572 loc = getSrcSpan dfun_id
575 See Note [Default methods and instances]
576 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
577 The default method Ids are already in the type environment (see Note
578 [Default method Ids and Template Haskell] in TcTyClsDcls), BUT they
579 don't have their InlinePragmas yet. Usually that would not matter,
580 because the simplifier propagates information from binding site to
581 use. But, unusually, when compiling instance decls we *copy* the
582 INLINE pragma from the default method to the method for that
583 particular operation (see Note [INLINE and default methods] below).
585 So right here in tcInstDecl2 we must re-extend the type envt with
586 the default method Ids replete with their INLINE pragmas. Urk.
589 tc_inst_decl2 :: Id -> InstBindings Name -> TcM (LHsBinds Id)
590 -- Returns a binding for the dfun
591 tc_inst_decl2 dfun_id inst_binds
592 = do { let rigid_info = InstSkol
593 inst_ty = idType dfun_id
594 loc = getSrcSpan dfun_id
596 -- Instantiate the instance decl with skolem constants
597 ; (inst_tyvars', dfun_theta', inst_head') <- tcSkolSigType rigid_info inst_ty
598 -- These inst_tyvars' scope over the 'where' part
599 -- Those tyvars are inside the dfun_id's type, which is a bit
600 -- bizarre, but OK so long as you realise it!
602 (clas, inst_tys') = tcSplitDFunHead inst_head'
603 (class_tyvars, sc_theta, sc_sels, op_items) = classBigSig clas
605 -- Instantiate the super-class context with inst_tys
606 sc_theta' = substTheta (zipOpenTvSubst class_tyvars inst_tys') sc_theta
608 -- Create dictionary Ids from the specified instance contexts.
609 ; dfun_ev_vars <- newEvVars dfun_theta'
610 ; self_dict <- newSelfDict clas inst_tys'
611 -- Default-method Ids may be mentioned in synthesised RHSs,
612 -- but they'll already be in the environment.
614 -- Cook up a binding for "self = df d1 .. dn",
615 -- to use in each method binding
616 -- Why? See Note [Subtle interaction of recursion and overlap]
617 ; let self_ev_bind = EvBind self_dict $
618 EvDFunApp dfun_id (mkTyVarTys inst_tyvars') dfun_ev_vars
620 -- Deal with 'SPECIALISE instance' pragmas
621 -- See Note [SPECIALISE instance pragmas]
622 ; spec_info <- tcSpecInstPrags dfun_id inst_binds
624 -- Typecheck the methods
625 ; (meth_ids, meth_binds)
626 <- tcExtendTyVarEnv inst_tyvars' $
627 tcInstanceMethods dfun_id clas inst_tyvars' dfun_ev_vars
628 inst_tys' self_ev_bind spec_info
631 -- Figure out bindings for the superclass context
632 ; let tc_sc = tcSuperClass inst_tyvars' dfun_ev_vars self_ev_bind
633 (sc_eqs, sc_dicts) = splitAt (classSCNEqs clas) sc_theta'
634 ; (sc_dict_ids, sc_binds) <- ASSERT( equalLength sc_sels sc_dicts )
635 ASSERT( all isEqPred sc_eqs )
636 mapAndUnzipM tc_sc (sc_sels `zip` sc_dicts)
639 ; (_eq_sc_binds, sc_eq_vars) <- checkConstraints InstSkol emptyVarSet
640 inst_tyvars' dfun_ev_vars $
641 emitWanteds ScOrigin sc_eqs
643 -- Create the result bindings
644 ; let dict_constr = classDataCon clas
645 dict_bind = mkVarBind self_dict dict_rhs
646 dict_rhs = foldl mk_app inst_constr dict_and_meth_ids
647 dict_and_meth_ids = sc_dict_ids ++ meth_ids
648 inst_constr = L loc $ wrapId (mkWpEvVarApps sc_eq_vars
649 <.> mkWpTyApps inst_tys')
650 (dataConWrapId dict_constr)
651 -- We don't produce a binding for the dict_constr; instead we
652 -- rely on the simplifier to unfold this saturated application
653 -- We do this rather than generate an HsCon directly, because
654 -- it means that the special cases (e.g. dictionary with only one
655 -- member) are dealt with by the common MkId.mkDataConWrapId code rather
656 -- than needing to be repeated here.
658 mk_app :: LHsExpr Id -> Id -> LHsExpr Id
659 mk_app fun arg_id = L loc (HsApp fun (L loc (wrapId arg_wrapper arg_id)))
660 arg_wrapper = mkWpEvVarApps dfun_ev_vars <.> mkWpTyApps (mkTyVarTys inst_tyvars')
662 -- Do not inline the dfun; instead give it a magic DFunFunfolding
663 -- See Note [ClassOp/DFun selection]
664 -- See also note [Single-method classes]
665 dfun_id_w_fun = dfun_id
666 `setIdUnfolding` mkDFunUnfolding inst_ty (map Var dict_and_meth_ids)
667 -- Not right for equality superclasses
668 `setInlinePragma` dfunInlinePragma
670 (spec_inst_prags, _) = spec_info
671 main_bind = AbsBinds { abs_tvs = inst_tyvars'
672 , abs_ev_vars = dfun_ev_vars
673 , abs_exports = [(inst_tyvars', dfun_id_w_fun, self_dict,
674 SpecPrags spec_inst_prags)]
675 , abs_ev_binds = emptyTcEvBinds
676 , abs_binds = unitBag dict_bind }
678 ; return (unitBag (L loc main_bind) `unionBags`
679 listToBag meth_binds `unionBags`
683 ------------------------------
684 tcSpecInstPrags :: DFunId -> InstBindings Name
685 -> TcM ([Located TcSpecPrag], PragFun)
686 tcSpecInstPrags _ (NewTypeDerived {})
687 = return ([], \_ -> [])
688 tcSpecInstPrags dfun_id (VanillaInst binds uprags _)
689 = do { spec_inst_prags <- mapM (wrapLocM (tcSpecInst dfun_id)) $
690 filter isSpecInstLSig uprags
691 -- The filter removes the pragmas for methods
692 ; return (spec_inst_prags, mkPragFun uprags binds) }
694 ------------------------------
695 tcSuperClass :: [TyVar] -> [EvVar]
697 -> (Id, PredType) -> TcM (Id, LHsBind Id)
698 -- Build a top level decl like
699 -- sc_op = /\a \d. let this = ... in
702 -- The "this" part is just-in-case (discarded if not used)
703 -- See Note [Recursive superclasses]
704 tcSuperClass tyvars dicts
705 self_ev_bind@(EvBind self_dict _)
707 = do { (ev_binds, wanted, sc_dict)
708 <- newImplication InstSkol emptyVarSet tyvars dicts $
709 emitWanted ScOrigin sc_pred
711 ; simplifySuperClass self_dict wanted
712 -- We include self_dict in the 'givens'; the simplifier
713 -- is clever enough to stop sc_pred geting bound by just
714 -- selecting from self_dict!!
717 ; let sc_op_ty = mkForAllTys tyvars $ mkPiTypes dicts (varType sc_dict)
718 sc_op_name = mkDerivedInternalName mkClassOpAuxOcc uniq
720 sc_op_id = mkLocalId sc_op_name sc_op_ty
721 sc_op_bind = VarBind { var_id = sc_op_id, var_inline = False
722 , var_rhs = L noSrcSpan $ wrapId sc_wrapper sc_dict }
723 sc_wrapper = mkWpTyLams tyvars
725 <.> mkWpLet (EvBinds (unitBag self_ev_bind))
728 ; return (sc_op_id, noLoc sc_op_bind) }
731 Note [Recursive superclasses]
732 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
733 See Trac #1470 for why we would *like* to add "self_dict" to the
734 available instances here. But we can't do so because then the superclases
735 get satisfied by selection from self_dict, and that leads to an immediate
736 loop. What we need is to add self_dict to Avails without adding its
737 superclasses, and we currently have no way to do that.
739 Note [SPECIALISE instance pragmas]
740 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
743 instance (Ix a, Ix b) => Ix (a,b) where
744 {-# SPECIALISE instance Ix (Int,Int) #-}
747 We do *not* want to make a specialised version of the dictionary
748 function. Rather, we want specialised versions of each method.
749 Thus we should generate something like this:
751 $dfIx :: (Ix a, Ix x) => Ix (a,b)
752 {- DFUN [$crange, ...] -}
753 $dfIx da db = Ix ($crange da db) (...other methods...)
755 $dfIxPair :: (Ix a, Ix x) => Ix (a,b)
756 {- DFUN [$crangePair, ...] -}
757 $dfIxPair = Ix ($crangePair da db) (...other methods...)
759 $crange :: (Ix a, Ix b) -> ((a,b),(a,b)) -> [(a,b)]
760 {-# SPECIALISE $crange :: ((Int,Int),(Int,Int)) -> [(Int,Int)] #-}
761 $crange da db = <blah>
763 {-# RULE range ($dfIx da db) = $crange da db #-}
767 * The RULE is unaffected by the specialisation. We don't want to
768 specialise $dfIx, because then it would need a specialised RULE
769 which is a pain. The single RULE works fine at all specialisations.
770 See Note [How instance declarations are translated] above
772 * Instead, we want to specialise the *method*, $crange
774 In practice, rather than faking up a SPECIALISE pragama for each
775 method (which is painful, since we'd have to figure out its
776 specialised type), we call tcSpecPrag *as if* were going to specialise
777 $dfIx -- you can see that in the call to tcSpecInst. That generates a
778 SpecPrag which, as it turns out, can be used unchanged for each method.
779 The "it turns out" bit is delicate, but it works fine!
782 tcSpecInst :: Id -> Sig Name -> TcM TcSpecPrag
783 tcSpecInst dfun_id prag@(SpecInstSig hs_ty)
784 = addErrCtxt (spec_ctxt prag) $
785 do { let name = idName dfun_id
786 ; (tyvars, theta, tau) <- tcHsInstHead hs_ty
787 ; let spec_ty = mkSigmaTy tyvars theta tau
788 ; co_fn <- tcSubType (SpecPragOrigin name) (SigSkol SpecInstCtxt)
789 (idType dfun_id) spec_ty
790 ; return (SpecPrag co_fn defaultInlinePragma) }
792 spec_ctxt prag = hang (ptext (sLit "In the SPECIALISE pragma")) 2 (ppr prag)
794 tcSpecInst _ _ = panic "tcSpecInst"
797 %************************************************************************
799 Type-checking an instance method
801 %************************************************************************
804 - Make the method bindings, as a [(NonRec, HsBinds)], one per method
805 - Remembering to use fresh Name (the instance method Name) as the binder
806 - Bring the instance method Ids into scope, for the benefit of tcInstSig
807 - Use sig_fn mapping instance method Name -> instance tyvars
809 - Use tcValBinds to do the checking
812 tcInstanceMethods :: DFunId -> Class -> [TcTyVar]
815 -> EvBind -- "This" and its binding
816 -> ([Located TcSpecPrag], PragFun)
819 -> TcM ([Id], [LHsBind Id])
820 -- The returned inst_meth_ids all have types starting
821 -- forall tvs. theta => ...
822 tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
823 self_dict_ev (spec_inst_prags, prag_fn)
824 op_items (VanillaInst binds _ standalone_deriv)
825 = mapAndUnzipM tc_item op_items
827 ----------------------
828 tc_item :: (Id, DefMeth) -> TcM (Id, LHsBind Id)
829 tc_item (sel_id, dm_info)
830 = case findMethodBind (idName sel_id) binds of
831 Just user_bind -> tc_body sel_id standalone_deriv user_bind
832 Nothing -> tc_default sel_id dm_info
834 ----------------------
835 tc_body :: Id -> Bool -> LHsBind Name -> TcM (TcId, LHsBind Id)
836 tc_body sel_id generated_code rn_bind
837 = add_meth_ctxt generated_code rn_bind $
838 do { (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars
840 ; (meth_id1, spec_prags) <- tcPrags NonRecursive False True
841 meth_id (prag_fn (idName sel_id))
843 ; bind <- tcInstanceMethodBody InstSkol
846 meth_id1 local_meth_id
848 (SpecPrags (spec_inst_prags ++ spec_prags))
850 ; return (meth_id1, bind) }
852 ----------------------
853 tc_default :: Id -> DefMeth -> TcM (TcId, LHsBind Id)
854 tc_default sel_id GenDefMeth -- Derivable type classes stuff
855 = do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id
856 ; tc_body sel_id False {- Not generated code? -} meth_bind }
858 tc_default sel_id NoDefMeth -- No default method at all
859 = do { warnMissingMethod sel_id
860 ; (meth_id, _) <- mkMethIds clas tyvars dfun_ev_vars
862 ; return (meth_id, mkVarBind meth_id $
863 mkLHsWrap lam_wrapper error_rhs) }
865 error_rhs = L loc $ HsApp error_fun error_msg
866 error_fun = L loc $ wrapId (WpTyApp meth_tau) nO_METHOD_BINDING_ERROR_ID
867 error_msg = L loc (HsLit (HsStringPrim (mkFastString error_string)))
868 meth_tau = funResultTy (applyTys (idType sel_id) inst_tys)
869 error_string = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
870 lam_wrapper = mkWpTyLams tyvars <.> mkWpLams dfun_ev_vars
872 tc_default sel_id (DefMeth dm_name) -- A polymorphic default method
873 = do { -- Build the typechecked version directly,
874 -- without calling typecheck_method;
875 -- see Note [Default methods in instances]
876 -- Generate /\as.\ds. let this = df as ds
877 -- in $dm inst_tys this
878 -- The 'let' is necessary only because HsSyn doesn't allow
879 -- you to apply a function to a dictionary *expression*.
881 ; (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars
883 ; dm_id <- tcLookupId dm_name
884 ; let dm_inline_prag = idInlinePragma dm_id
885 EvBind self_dict _ = self_dict_ev
886 rhs = HsWrap (mkWpEvVarApps [self_dict] <.> mkWpTyApps inst_tys) $
889 meth_bind = L loc $ VarBind { var_id = local_meth_id
890 , var_rhs = L loc rhs
891 , var_inline = False }
892 meth_id1 = meth_id `setInlinePragma` dm_inline_prag
893 -- Copy the inline pragma (if any) from the default
894 -- method to this version. Note [INLINE and default methods]
896 bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars
897 , abs_exports = [( tyvars, meth_id1, local_meth_id
898 , SpecPrags spec_inst_prags)]
899 , abs_ev_binds = EvBinds (unitBag self_dict_ev)
900 , abs_binds = unitBag meth_bind }
901 -- Default methods in an instance declaration can't have their own
902 -- INLINE or SPECIALISE pragmas. It'd be possible to allow them, but
903 -- currently they are rejected with
904 -- "INLINE pragma lacks an accompanying binding"
906 ; return (meth_id1, L loc bind) }
908 ----------------------
909 loc = getSrcSpan dfun_id
910 meth_sig_fn _ = Just ([],loc) -- The 'Just' says "yes, there's a type sig"
911 -- But there are no scoped type variables from local_method_id
912 -- Only the ones from the instance decl itself, which are already
913 -- in scope. Example:
914 -- class C a where { op :: forall b. Eq b => ... }
915 -- instance C [c] where { op = <rhs> }
916 -- In <rhs>, 'c' is scope but 'b' is not!
918 mb_dict_ev = if null tyvars then Nothing else Just self_dict_ev
919 -- Only need the self_dict stuff if there are type
920 -- variables involved; otherwise overlap is not possible
921 -- See Note [Subtle interaction of recursion and overlap]
924 -- For instance decls that come from standalone deriving clauses
925 -- we want to print out the full source code if there's an error
926 -- because otherwise the user won't see the code at all
927 add_meth_ctxt generated_code rn_bind thing
928 | generated_code = addLandmarkErrCtxt (derivBindCtxt clas inst_tys rn_bind) thing
932 tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
933 _ _ op_items (NewTypeDerived coi _)
936 -- class Show b => Foo a b where
938 -- newtype N a = MkN (Tree [a])
939 -- deriving instance (Show p, Foo Int p) => Foo Int (N p)
940 -- -- NB: standalone deriving clause means
941 -- -- that the contex is user-specified
942 -- Hence op :: forall a b. Foo a b => a -> b -> b
944 -- We're going to make an instance like
945 -- instance (Show p, Foo Int p) => Foo Int (N p)
948 -- $copT :: forall p. (Show p, Foo Int p) => Int -> N p -> N p
949 -- $copT p (d1:Show p) (d2:Foo Int p)
950 -- = op Int (Tree [p]) rep_d |> op_co
952 -- rep_d :: Foo Int (Tree [p]) = ...d1...d2...
953 -- op_co :: (Int -> Tree [p] -> Tree [p]) ~ (Int -> T p -> T p)
954 -- We get op_co by substituting [Int/a] and [co/b] in type for op
955 -- where co : [p] ~ T p
957 -- Notice that the dictionary bindings "..d1..d2.." must be generated
958 -- by the constraint solver, since the <context> may be
961 = do { rep_d_stuff <- checkConstraints InstSkol emptyVarSet tyvars dfun_ev_vars $
962 emitWanted ScOrigin rep_pred
964 ; mapAndUnzipM (tc_item rep_d_stuff) op_items }
966 loc = getSrcSpan dfun_id
968 inst_tvs = fst (tcSplitForAllTys (idType dfun_id))
969 Just (init_inst_tys, _) = snocView inst_tys
970 rep_ty = fst (coercionKind co) -- [p]
971 rep_pred = mkClassPred clas (init_inst_tys ++ [rep_ty])
974 co = substTyWith inst_tvs (mkTyVarTys tyvars) $
975 case coi of { IdCo ty -> ty ;
976 ACo co -> mkSymCoercion co }
979 tc_item :: (TcEvBinds, EvVar) -> (Id, DefMeth) -> TcM (TcId, LHsBind TcId)
980 tc_item (rep_ev_binds, rep_d) (sel_id, _)
981 = do { (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars
984 ; let meth_rhs = wrapId (mk_op_wrapper sel_id rep_d) sel_id
985 meth_bind = VarBind { var_id = local_meth_id
986 , var_rhs = L loc meth_rhs
987 , var_inline = False }
989 bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars
990 , abs_exports = [(tyvars, meth_id,
991 local_meth_id, noSpecPrags)]
992 , abs_ev_binds = rep_ev_binds
993 , abs_binds = unitBag $ L loc meth_bind }
995 ; return (meth_id, L loc bind) }
998 mk_op_wrapper :: Id -> EvVar -> HsWrapper
999 mk_op_wrapper sel_id rep_d
1000 = WpCast (substTyWith sel_tvs (init_inst_tys ++ [co]) local_meth_ty)
1001 <.> WpEvApp (EvId rep_d)
1002 <.> mkWpTyApps (init_inst_tys ++ [rep_ty])
1004 (sel_tvs, sel_rho) = tcSplitForAllTys (idType sel_id)
1005 (_, local_meth_ty) = tcSplitPredFunTy_maybe sel_rho
1006 `orElse` pprPanic "tcInstanceMethods" (ppr sel_id)
1008 ----------------------
1009 mkMethIds :: Class -> [TcTyVar] -> [EvVar] -> [TcType] -> Id -> TcM (TcId, TcId)
1010 mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id
1011 = do { uniq <- newUnique
1012 ; let meth_name = mkDerivedInternalName mkClassOpAuxOcc uniq sel_name
1013 ; local_meth_name <- newLocalName sel_name
1014 -- Base the local_meth_name on the selector name, becuase
1015 -- type errors from tcInstanceMethodBody come from here
1017 ; let meth_id = mkLocalId meth_name meth_ty
1018 local_meth_id = mkLocalId local_meth_name local_meth_ty
1019 ; return (meth_id, local_meth_id) }
1021 local_meth_ty = instantiateMethod clas sel_id inst_tys
1022 meth_ty = mkForAllTys tyvars $ mkPiTypes dfun_ev_vars local_meth_ty
1023 sel_name = idName sel_id
1025 ----------------------
1026 wrapId :: HsWrapper -> id -> HsExpr id
1027 wrapId wrapper id = mkHsWrap wrapper (HsVar id)
1029 derivBindCtxt :: Class -> [Type ] -> LHsBind Name -> SDoc
1030 derivBindCtxt clas tys bind
1031 = vcat [ ptext (sLit "When typechecking a standalone-derived method for")
1032 <+> quotes (pprClassPred clas tys) <> colon
1033 , nest 2 $ pprSetDepth AllTheWay $ ppr bind ]
1035 warnMissingMethod :: Id -> TcM ()
1036 warnMissingMethod sel_id
1037 = do { warn <- doptM Opt_WarnMissingMethods
1038 ; warnTc (warn -- Warn only if -fwarn-missing-methods
1039 && not (startsWithUnderscore (getOccName sel_id)))
1040 -- Don't warn about _foo methods
1041 (ptext (sLit "No explicit method nor default method for")
1042 <+> quotes (ppr sel_id)) }
1045 Note [Export helper functions]
1046 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1047 We arrange to export the "helper functions" of an instance declaration,
1048 so that they are not subject to preInlineUnconditionally, even if their
1049 RHS is trivial. Reason: they are mentioned in the DFunUnfolding of
1050 the dict fun as Ids, not as CoreExprs, so we can't substitute a
1051 non-variable for them.
1053 We could change this by making DFunUnfoldings have CoreExprs, but it
1054 seems a bit simpler this way.
1056 Note [Default methods in instances]
1057 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1064 instance Baz Int Int
1066 From the class decl we get
1068 $dmfoo :: forall v x. Baz v x => x -> x
1071 Notice that the type is ambiguous. That's fine, though. The instance
1074 $dBazIntInt = MkBaz fooIntInt
1075 fooIntInt = $dmfoo Int Int $dBazIntInt
1077 BUT this does mean we must generate the dictionary translation of
1078 fooIntInt directly, rather than generating source-code and
1079 type-checking it. That was the bug in Trac #1061. In any case it's
1080 less work to generate the translated version!
1082 Note [INLINE and default methods]
1083 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1084 Default methods need special case. They are supposed to behave rather like
1085 macros. For exmample
1088 op1, op2 :: Bool -> a -> a
1091 op1 b x = op2 (not b) x
1093 instance Foo Int where
1094 -- op1 via default method
1097 The instance declaration should behave
1099 just as if 'op1' had been defined with the
1100 code, and INLINE pragma, from its original
1103 That is, just as if you'd written
1105 instance Foo Int where
1109 op1 b x = op2 (not b) x
1111 So for the above example we generate:
1114 {-# INLINE $dmop1 #-}
1115 -- $dmop1 has an InlineCompulsory unfolding
1116 $dmop1 d b x = op2 d (not b) x
1118 $fFooInt = MkD $cop1 $cop2
1120 {-# INLINE $cop1 #-}
1121 $cop1 = $dmop1 $fFooInt
1127 * We *copy* any INLINE pragma from the default method $dmop1 to the
1128 instance $cop1. Otherwise we'll just inline the former in the
1129 latter and stop, which isn't what the user expected
1131 * Regardless of its pragma, we give the default method an
1132 unfolding with an InlineCompulsory source. That means
1133 that it'll be inlined at every use site, notably in
1134 each instance declaration, such as $cop1. This inlining
1135 must happen even though
1136 a) $dmop1 is not saturated in $cop1
1137 b) $cop1 itself has an INLINE pragma
1139 It's vital that $dmop1 *is* inlined in this way, to allow the mutual
1140 recursion between $fooInt and $cop1 to be broken
1142 * To communicate the need for an InlineCompulsory to the desugarer
1143 (which makes the Unfoldings), we use the IsDefaultMethod constructor
1147 %************************************************************************
1149 \subsection{Error messages}
1151 %************************************************************************
1154 instDeclCtxt1 :: LHsType Name -> SDoc
1155 instDeclCtxt1 hs_inst_ty
1156 = inst_decl_ctxt (case unLoc hs_inst_ty of
1157 HsForAllTy _ _ _ (L _ (HsPredTy pred)) -> ppr pred
1158 HsPredTy pred -> ppr pred
1159 _ -> ppr hs_inst_ty) -- Don't expect this
1160 instDeclCtxt2 :: Type -> SDoc
1161 instDeclCtxt2 dfun_ty
1162 = inst_decl_ctxt (ppr (mkClassPred cls tys))
1164 (_,cls,tys) = tcSplitDFunTy dfun_ty
1166 inst_decl_ctxt :: SDoc -> SDoc
1167 inst_decl_ctxt doc = ptext (sLit "In the instance declaration for") <+> quotes doc
1169 atInstCtxt :: Name -> SDoc
1170 atInstCtxt name = ptext (sLit "In the associated type instance for") <+>
1173 mustBeVarArgErr :: Type -> SDoc
1174 mustBeVarArgErr ty =
1175 sep [ ptext (sLit "Arguments that do not correspond to a class parameter") <+>
1176 ptext (sLit "must be variables")
1177 , ptext (sLit "Instead of a variable, found") <+> ppr ty
1180 wrongATArgErr :: Type -> Type -> SDoc
1181 wrongATArgErr ty instTy =
1182 sep [ ptext (sLit "Type indexes must match class instance head")
1183 , ptext (sLit "Found") <+> quotes (ppr ty)
1184 <+> ptext (sLit "but expected") <+> quotes (ppr instTy)