Fix recursive superclasses (again). Fixes Trac #4809.
[ghc-hetmet.git] / compiler / typecheck / TcInstDcls.lhs
1 %
2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 %
5
6 TcInstDecls: Typechecking instance declarations
7
8 \begin{code}
9 module TcInstDcls ( tcInstDecls1, tcInstDecls2 ) where
10
11 import HsSyn
12 import TcBinds
13 import TcTyClsDecls
14 import TcClassDcl
15 import TcPat( addInlinePrags )
16 import TcSimplify( simplifyTop )
17 import TcRnMonad
18 import TcMType
19 import TcType
20 import Inst
21 import InstEnv
22 import FamInst
23 import FamInstEnv
24 import MkCore   ( nO_METHOD_BINDING_ERROR_ID )
25 import TcDeriv
26 import TcEnv
27 import RnSource ( addTcgDUs )
28 import TcHsType
29 import TcUnify
30 import Type
31 import Coercion
32 import TyCon
33 import DataCon
34 import Class
35 import Var
36 import VarSet
37 import CoreUtils  ( mkPiTypes )
38 import CoreUnfold ( mkDFunUnfolding )
39 import CoreSyn    ( Expr(Var), DFunArg(..), CoreExpr )
40 import Id
41 import MkId
42 import Name
43 import NameSet
44 import DynFlags
45 import SrcLoc
46 import Util
47 import Outputable
48 import Bag
49 import BasicTypes
50 import HscTypes
51 import FastString
52 import Maybes   ( orElse )
53 import Data.Maybe
54 import Control.Monad
55 import Data.List
56
57 #include "HsVersions.h"
58 \end{code}
59
60 Typechecking instance declarations is done in two passes. The first
61 pass, made by @tcInstDecls1@, collects information to be used in the
62 second pass.
63
64 This pre-processed info includes the as-yet-unprocessed bindings
65 inside the instance declaration.  These are type-checked in the second
66 pass, when the class-instance envs and GVE contain all the info from
67 all the instance and value decls.  Indeed that's the reason we need
68 two passes over the instance decls.
69
70
71 Note [How instance declarations are translated]
72 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
73 Here is how we translation instance declarations into Core
74
75 Running example:
76         class C a where
77            op1, op2 :: Ix b => a -> b -> b
78            op2 = <dm-rhs>
79
80         instance C a => C [a]
81            {-# INLINE [2] op1 #-}
82            op1 = <rhs>
83 ===>
84         -- Method selectors
85         op1,op2 :: forall a. C a => forall b. Ix b => a -> b -> b
86         op1 = ...
87         op2 = ...
88
89         -- Default methods get the 'self' dictionary as argument
90         -- so they can call other methods at the same type
91         -- Default methods get the same type as their method selector
92         $dmop2 :: forall a. C a => forall b. Ix b => a -> b -> b
93         $dmop2 = /\a. \(d:C a). /\b. \(d2: Ix b). <dm-rhs>
94                -- NB: type variables 'a' and 'b' are *both* in scope in <dm-rhs>
95                -- Note [Tricky type variable scoping]
96
97         -- A top-level definition for each instance method
98         -- Here op1_i, op2_i are the "instance method Ids"
99         -- The INLINE pragma comes from the user pragma
100         {-# INLINE [2] op1_i #-}  -- From the instance decl bindings
101         op1_i, op2_i :: forall a. C a => forall b. Ix b => [a] -> b -> b
102         op1_i = /\a. \(d:C a). 
103                let this :: C [a]
104                    this = df_i a d
105                      -- Note [Subtle interaction of recursion and overlap]
106
107                    local_op1 :: forall b. Ix b => [a] -> b -> b
108                    local_op1 = <rhs>
109                      -- Source code; run the type checker on this
110                      -- NB: Type variable 'a' (but not 'b') is in scope in <rhs>
111                      -- Note [Tricky type variable scoping]
112
113                in local_op1 a d
114
115         op2_i = /\a \d:C a. $dmop2 [a] (df_i a d) 
116
117         -- The dictionary function itself
118         {-# NOINLINE CONLIKE df_i #-}   -- Never inline dictionary functions
119         df_i :: forall a. C a -> C [a]
120         df_i = /\a. \d:C a. MkC (op1_i a d) (op2_i a d)
121                 -- But see Note [Default methods in instances]
122                 -- We can't apply the type checker to the default-method call
123
124         -- Use a RULE to short-circuit applications of the class ops
125         {-# RULE "op1@C[a]" forall a, d:C a. 
126                             op1 [a] (df_i d) = op1_i a d #-}
127
128 Note [Instances and loop breakers]
129 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
130 * Note that df_i may be mutually recursive with both op1_i and op2_i.
131   It's crucial that df_i is not chosen as the loop breaker, even 
132   though op1_i has a (user-specified) INLINE pragma.
133
134 * Instead the idea is to inline df_i into op1_i, which may then select
135   methods from the MkC record, and thereby break the recursion with
136   df_i, leaving a *self*-recurisve op1_i.  (If op1_i doesn't call op at
137   the same type, it won't mention df_i, so there won't be recursion in
138   the first place.)  
139
140 * If op1_i is marked INLINE by the user there's a danger that we won't
141   inline df_i in it, and that in turn means that (since it'll be a
142   loop-breaker because df_i isn't), op1_i will ironically never be 
143   inlined.  But this is OK: the recursion breaking happens by way of
144   a RULE (the magic ClassOp rule above), and RULES work inside InlineRule
145   unfoldings. See Note [RULEs enabled in SimplGently] in SimplUtils
146
147 Note [ClassOp/DFun selection]
148 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
149 One thing we see a lot is stuff like
150     op2 (df d1 d2)
151 where 'op2' is a ClassOp and 'df' is DFun.  Now, we could inline *both*
152 'op2' and 'df' to get
153      case (MkD ($cop1 d1 d2) ($cop2 d1 d2) ... of
154        MkD _ op2 _ _ _ -> op2
155 And that will reduce to ($cop2 d1 d2) which is what we wanted.
156
157 But it's tricky to make this work in practice, because it requires us to 
158 inline both 'op2' and 'df'.  But neither is keen to inline without having
159 seen the other's result; and it's very easy to get code bloat (from the 
160 big intermediate) if you inline a bit too much.
161
162 Instead we use a cunning trick.
163  * We arrange that 'df' and 'op2' NEVER inline.  
164
165  * We arrange that 'df' is ALWAYS defined in the sylised form
166       df d1 d2 = MkD ($cop1 d1 d2) ($cop2 d1 d2) ...
167
168  * We give 'df' a magical unfolding (DFunUnfolding [$cop1, $cop2, ..])
169    that lists its methods.
170
171  * We make CoreUnfold.exprIsConApp_maybe spot a DFunUnfolding and return
172    a suitable constructor application -- inlining df "on the fly" as it 
173    were.
174
175  * We give the ClassOp 'op2' a BuiltinRule that extracts the right piece
176    iff its argument satisfies exprIsConApp_maybe.  This is done in
177    MkId mkDictSelId
178
179  * We make 'df' CONLIKE, so that shared uses stil match; eg
180       let d = df d1 d2
181       in ...(op2 d)...(op1 d)...
182
183 Note [Single-method classes]
184 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
185 If the class has just one method (or, more accurately, just one element
186 of {superclasses + methods}), then we still use the *same* strategy
187
188    class C a where op :: a -> a
189    instance C a => C [a] where op = <blah>
190
191 We translate the class decl into a newtype, which just gives
192 a top-level axiom:
193
194    axiom Co:C a :: C a ~ (a->a)
195
196    op :: forall a. C a -> (a -> a)
197    op a d = d |> (Co:C a)
198
199    MkC :: forall a. (a->a) -> C a
200    MkC = /\a.\op. op |> (sym Co:C a)
201
202    df :: forall a. C a => C [a]
203    {-# NOINLINE df   DFun[ $cop_list ] #-}
204    df = /\a. \d. MkC ($cop_list a d)
205
206    $cop_list :: forall a. C a => [a] -> [a]
207    $cop_list = <blah>
208
209 The "constructor" MkC expands to a cast, as does the class-op selector.
210 The RULE works just like for multi-field dictionaries:
211
212   * (df a d) returns (Just (MkC,..,[$cop_list a d])) 
213     to exprIsConApp_Maybe
214
215   * The RULE for op picks the right result
216
217 This is a bit of a hack, because (df a d) isn't *really* a constructor
218 application.  But it works just fine in this case, exprIsConApp_maybe
219 is otherwise used only when we hit a case expression which will have
220 a real data constructor in it.
221
222 The biggest reason for doing it this way, apart from uniformity, is
223 that we want to be very careful when we have
224     instance C a => C [a] where
225       {-# INLINE op #-}
226       op = ...
227 then we'll get an INLINE pragma on $cop_list but it's important that
228 $cop_list only inlines when it's applied to *two* arguments (the
229 dictionary and the list argument
230
231 The danger is that we'll get something like
232       op_list :: C a => [a] -> [a]
233       op_list = /\a.\d. $cop_list a d
234 and then we'll eta expand, and then we'll inline TOO EARLY. This happened in 
235 Trac #3772 and I spent far too long fiddling around trying to fix it.
236 Look at the test for Trac #3772.
237
238      (Note: re-reading the above, I can't see how using the
239             uniform story solves the problem.)
240
241 Note [Subtle interaction of recursion and overlap]
242 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
243 Consider this
244   class C a where { op1,op2 :: a -> a }
245   instance C a => C [a] where
246     op1 x = op2 x ++ op2 x
247     op2 x = ...
248   instance C [Int] where
249     ...
250
251 When type-checking the C [a] instance, we need a C [a] dictionary (for
252 the call of op2).  If we look up in the instance environment, we find
253 an overlap.  And in *general* the right thing is to complain (see Note
254 [Overlapping instances] in InstEnv).  But in *this* case it's wrong to
255 complain, because we just want to delegate to the op2 of this same
256 instance.  
257
258 Why is this justified?  Because we generate a (C [a]) constraint in 
259 a context in which 'a' cannot be instantiated to anything that matches
260 other overlapping instances, or else we would not be excecuting this
261 version of op1 in the first place.
262
263 It might even be a bit disguised:
264
265   nullFail :: C [a] => [a] -> [a]
266   nullFail x = op2 x ++ op2 x
267
268   instance C a => C [a] where
269     op1 x = nullFail x
270
271 Precisely this is used in package 'regex-base', module Context.hs.
272 See the overlapping instances for RegexContext, and the fact that they
273 call 'nullFail' just like the example above.  The DoCon package also
274 does the same thing; it shows up in module Fraction.hs
275
276 Conclusion: when typechecking the methods in a C [a] instance, we want to
277 treat the 'a' as an *existential* type variable, in the sense described
278 by Note [Binding when looking up instances].  That is why isOverlappableTyVar
279 responds True to an InstSkol, which is the kind of skolem we use in
280 tcInstDecl2.
281
282
283 Note [Tricky type variable scoping]
284 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
285 In our example
286         class C a where
287            op1, op2 :: Ix b => a -> b -> b
288            op2 = <dm-rhs>
289
290         instance C a => C [a]
291            {-# INLINE [2] op1 #-}
292            op1 = <rhs>
293
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>.
300
301
302
303 %************************************************************************
304 %*                                                                      *
305 \subsection{Extracting instance decls}
306 %*                                                                      *
307 %************************************************************************
308
309 Gather up the instance declarations from their various sources
310
311 \begin{code}
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
320
321 tcInstDecls1 tycl_decls inst_decls deriv_decls
322   = checkNoErrs $
323     do {        -- Stop if addInstInfos etc discovers any errors
324                 -- (they recover, so that we get more than one error each
325                 -- round)
326
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
331
332        ; let { (local_info,
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
338              }
339
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 {
343
344                 -- (3) Instances from generic class declarations
345        ; generic_inst_info <- getGenericInstances clas_decls
346
347                 -- Next, construct the instance environment so far, consisting
348                 -- of
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 {
355
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
363                                 -- more errors still
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)
370     }}}
371
372 addInsts :: [InstInfo Name] -> TcM a -> TcM a
373 addInsts infos thing_inside
374   = tcExtendLocalInstEnv (map iSpec infos) thing_inside
375
376 addFamInsts :: [TyThing] -> TcM a -> TcM a
377 addFamInsts tycons thing_inside
378   = tcExtendLocalFamInstEnv (map mkLocalFamInstTyThing tycons) thing_inside
379   where
380     mkLocalFamInstTyThing (ATyCon tycon) = mkLocalFamInst tycon
381     mkLocalFamInstTyThing tything        = pprPanic "TcInstDcls.addFamInsts"
382                                                     (ppr tything)
383 \end{code}
384
385 \begin{code}
386 tcLocalInstDecl1 :: LInstDecl Name
387                  -> TcM (InstInfo Name, [TyThing])
388         -- A source-file instance declaration
389         -- Type-check all the stuff before the "where"
390         --
391         -- We check for respectable instance type, and context
392 tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats))
393   = setSrcSpan loc                      $
394     addErrCtxt (instDeclCtxt1 poly_ty)  $
395
396     do  { is_boot <- tcIsHsBoot
397         ; checkTc (not is_boot || (isEmptyLHsBinds binds && null uprags))
398                   badBootDeclErr
399
400         ; (tyvars, theta, clas, inst_tys) <- tcHsInstHead poly_ty
401         ; checkValidInstance poly_ty tyvars theta clas inst_tys
402
403         -- Next, process any associated types.
404         ; idx_tycons <- recoverM (return []) $
405                      do { idx_tycons <- checkNoErrs $ 
406                                         mapAndRecoverM (tcFamInstDecl NotTopLevel) ats
407                         ; checkValidAndMissingATs clas (tyvars, inst_tys)
408                                                   (zip ats idx_tycons)
409                         ; return idx_tycons }
410
411         -- Finally, construct the Core representation of the instance.
412         -- (This no longer includes the associated types.)
413         ; dfun_name <- newDFunName clas inst_tys (getLoc poly_ty)
414                 -- Dfun location is that of instance *header*
415         ; overlap_flag <- getOverlapFlag
416         ; let (eq_theta,dict_theta) = partition isEqPred theta
417               theta'         = eq_theta ++ dict_theta
418               dfun           = mkDictFunId dfun_name tyvars theta' clas inst_tys
419               ispec          = mkLocalInstance dfun overlap_flag
420
421         ; return (InstInfo { iSpec  = ispec, iBinds = VanillaInst binds uprags False },
422                   idx_tycons)
423         }
424   where
425     -- We pass in the source form and the type checked form of the ATs.  We
426     -- really need the source form only to be able to produce more informative
427     -- error messages.
428     checkValidAndMissingATs :: Class
429                             -> ([TyVar], [TcType])     -- instance types
430                             -> [(LTyClDecl Name,       -- source form of AT
431                                  TyThing)]             -- Core form of AT
432                             -> TcM ()
433     checkValidAndMissingATs clas inst_tys ats
434       = do { -- Issue a warning for each class AT that is not defined in this
435              -- instance.
436            ; let class_ats   = map tyConName (classATs clas)
437                  defined_ats = listToNameSet . map (tcdName.unLoc.fst)  $ ats
438                  omitted     = filterOut (`elemNameSet` defined_ats) class_ats
439            ; warn <- doptM Opt_WarnMissingMethods
440            ; mapM_ (warnTc warn . omittedATWarn) omitted
441
442              -- Ensure that all AT indexes that correspond to class parameters
443              -- coincide with the types in the instance head.  All remaining
444              -- AT arguments must be variables.  Also raise an error for any
445              -- type instances that are not associated with this class.
446            ; mapM_ (checkIndexes clas inst_tys) ats
447            }
448
449     checkIndexes clas inst_tys (hsAT, ATyCon tycon)
450 -- !!!TODO: check that this does the Right Thing for indexed synonyms, too!
451       = checkIndexes' clas inst_tys hsAT
452                       (tyConTyVars tycon,
453                        snd . fromJust . tyConFamInst_maybe $ tycon)
454     checkIndexes _ _ _ = panic "checkIndexes"
455
456     checkIndexes' clas (instTvs, instTys) hsAT (atTvs, atTys)
457       = let atName = tcdName . unLoc $ hsAT
458         in
459         setSrcSpan (getLoc hsAT)       $
460         addErrCtxt (atInstCtxt atName) $
461         case find ((atName ==) . tyConName) (classATs clas) of
462           Nothing     -> addErrTc $ badATErr clas atName  -- not in this class
463           Just atycon ->
464                 -- The following is tricky!  We need to deal with three
465                 -- complications: (1) The AT possibly only uses a subset of
466                 -- the class parameters as indexes and those it uses may be in
467                 -- a different order; (2) the AT may have extra arguments,
468                 -- which must be type variables; and (3) variables in AT and
469                 -- instance head will be different `Name's even if their
470                 -- source lexemes are identical.
471                 --
472                 -- e.g.    class C a b c where 
473                 --           data D b a :: * -> *           -- NB (1) b a, omits c
474                 --         instance C [x] Bool Char where 
475                 --           data D Bool [x] v = MkD x [v]  -- NB (2) v
476                 --                -- NB (3) the x in 'instance C...' have differnt
477                 --                --        Names to x's in 'data D...'
478                 --
479                 -- Re (1), `poss' contains a permutation vector to extract the
480                 -- class parameters in the right order.
481                 --
482                 -- Re (2), we wrap the (permuted) class parameters in a Maybe
483                 -- type and use Nothing for any extra AT arguments.  (First
484                 -- equation of `checkIndex' below.)
485                 --
486                 -- Re (3), we replace any type variable in the AT parameters
487                 -- that has the same source lexeme as some variable in the
488                 -- instance types with the instance type variable sharing its
489                 -- source lexeme.
490                 --
491                 let poss :: [Int]
492                     -- For *associated* type families, gives the position
493                     -- of that 'TyVar' in the class argument list (0-indexed)
494                     -- e.g.  class C a b c where { type F c a :: *->* }
495                     --       Then we get Just [2,0]
496                     poss = catMaybes [ tv `elemIndex` classTyVars clas 
497                                      | tv <- tyConTyVars atycon]
498                        -- We will get Nothings for the "extra" type 
499                        -- variables in an associated data type
500                        -- e.g. class C a where { data D a :: *->* }
501                        -- here D gets arity 2 and has two tyvars
502
503                     relevantInstTys = map (instTys !!) poss
504                     instArgs        = map Just relevantInstTys ++
505                                       repeat Nothing  -- extra arguments
506                     renaming        = substSameTyVar atTvs instTvs
507                 in
508                 zipWithM_ checkIndex (substTys renaming atTys) instArgs
509
510     checkIndex ty Nothing
511       | isTyVarTy ty         = return ()
512       | otherwise            = addErrTc $ mustBeVarArgErr ty
513     checkIndex ty (Just instTy)
514       | ty `tcEqType` instTy = return ()
515       | otherwise            = addErrTc $ wrongATArgErr ty instTy
516
517     listToNameSet = addListToNameSet emptyNameSet
518
519     substSameTyVar []       _            = emptyTvSubst
520     substSameTyVar (tv:tvs) replacingTvs =
521       let replacement = case find (tv `sameLexeme`) replacingTvs of
522                         Nothing  -> mkTyVarTy tv
523                         Just rtv -> mkTyVarTy rtv
524           --
525           tv1 `sameLexeme` tv2 =
526             nameOccName (tyVarName tv1) == nameOccName (tyVarName tv2)
527       in
528       extendTvSubst (substSameTyVar tvs replacingTvs) tv replacement
529 \end{code}
530
531
532 %************************************************************************
533 %*                                                                      *
534       Type-checking instance declarations, pass 2
535 %*                                                                      *
536 %************************************************************************
537
538 \begin{code}
539 tcInstDecls2 :: [LTyClDecl Name] -> [InstInfo Name]
540              -> TcM (LHsBinds Id)
541 -- (a) From each class declaration,
542 --      generate any default-method bindings
543 -- (b) From each instance decl
544 --      generate the dfun binding
545
546 tcInstDecls2 tycl_decls inst_decls
547   = do  { -- (a) Default methods from class decls
548           let class_decls = filter (isClassDecl . unLoc) tycl_decls
549         ; dm_binds_s <- mapM tcClassDecl2 class_decls
550         ; let dm_binds = unionManyBags dm_binds_s
551                                     
552           -- (b) instance declarations
553         ; let dm_ids = collectHsBindsBinders dm_binds
554               -- Add the default method Ids (again)
555               -- See Note [Default methods and instances]
556         ; inst_binds_s <- tcExtendIdEnv dm_ids $
557                           mapM tcInstDecl2 inst_decls
558
559           -- Done
560         ; return (dm_binds `unionBags` unionManyBags inst_binds_s) }
561 \end{code}
562
563 See Note [Default methods and instances]
564 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
565 The default method Ids are already in the type environment (see Note
566 [Default method Ids and Template Haskell] in TcTyClsDcls), BUT they
567 don't have their InlinePragmas yet.  Usually that would not matter,
568 because the simplifier propagates information from binding site to
569 use.  But, unusually, when compiling instance decls we *copy* the
570 INLINE pragma from the default method to the method for that
571 particular operation (see Note [INLINE and default methods] below).
572
573 So right here in tcInstDecl2 we must re-extend the type envt with
574 the default method Ids replete with their INLINE pragmas.  Urk.
575
576 \begin{code}
577
578 tcInstDecl2 :: InstInfo Name -> TcM (LHsBinds Id)
579             -- Returns a binding for the dfun
580 tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
581   = recoverM (return emptyLHsBinds)             $
582     setSrcSpan loc                              $
583     addErrCtxt (instDeclCtxt2 (idType dfun_id)) $ 
584     do {  -- Instantiate the instance decl with skolem constants
585        ; (inst_tyvars, dfun_theta, inst_head) <- tcSkolSigType skol_info (idType dfun_id)
586        ; let (clas, inst_tys) = tcSplitDFunHead inst_head
587              (class_tyvars, sc_theta, _, op_items) = classBigSig clas
588              sc_theta' = substTheta (zipOpenTvSubst class_tyvars inst_tys) sc_theta
589              n_ty_args = length inst_tyvars
590              n_silent  = dfunNSilent dfun_id
591              (silent_theta, orig_theta) = splitAt n_silent dfun_theta
592
593        ; silent_ev_vars <- mapM newSilentGiven silent_theta
594        ; orig_ev_vars   <- newEvVars orig_theta
595        ; let dfun_ev_vars = silent_ev_vars ++ orig_ev_vars
596
597        ; (sc_binds, sc_dicts, sc_args)
598              <- mapAndUnzip3M (tcSuperClass n_ty_args dfun_ev_vars) sc_theta'
599
600        -- Check that any superclasses gotten from a silent arguemnt
601        -- can be deduced from the originally-specified dfun arguments
602        ; ct_loc <- getCtLoc ScOrigin
603        ; _ <- checkConstraints skol_info inst_tyvars orig_ev_vars $
604               emitConstraints $ listToBag $
605               [ WcEvVar (WantedEvVar sc ct_loc)
606               | sc <- sc_dicts, isSilentEvVar sc ]
607
608        -- Deal with 'SPECIALISE instance' pragmas
609        -- See Note [SPECIALISE instance pragmas]
610        ; spec_info <- tcSpecInstPrags dfun_id ibinds
611
612         -- Typecheck the methods
613        ; (meth_ids, meth_binds) 
614            <- tcExtendTyVarEnv inst_tyvars $
615                 -- The inst_tyvars scope over the 'where' part
616                 -- Those tyvars are inside the dfun_id's type, which is a bit
617                 -- bizarre, but OK so long as you realise it!
618               tcInstanceMethods dfun_id clas inst_tyvars dfun_ev_vars
619                                 inst_tys spec_info
620                                 op_items ibinds
621
622        -- Create the result bindings
623        ; self_dict <- newEvVar (ClassP clas inst_tys)
624        ; let dict_constr       = classDataCon clas
625              dict_bind         = mkVarBind self_dict dict_rhs
626              dict_rhs          = foldl mk_app inst_constr $
627                                  map HsVar sc_dicts ++ map (wrapId arg_wrapper) meth_ids
628              inst_constr       = L loc $ wrapId (mkWpTyApps inst_tys)
629                                                 (dataConWrapId dict_constr)
630                      -- We don't produce a binding for the dict_constr; instead we
631                      -- rely on the simplifier to unfold this saturated application
632                      -- We do this rather than generate an HsCon directly, because
633                      -- it means that the special cases (e.g. dictionary with only one
634                      -- member) are dealt with by the common MkId.mkDataConWrapId code rather
635                      -- than needing to be repeated here.
636
637              mk_app :: LHsExpr Id -> HsExpr Id -> LHsExpr Id
638              mk_app fun arg = L loc (HsApp fun (L loc arg))
639
640              arg_wrapper = mkWpEvVarApps dfun_ev_vars <.> mkWpTyApps (mkTyVarTys inst_tyvars)
641
642                 -- Do not inline the dfun; instead give it a magic DFunFunfolding
643                 -- See Note [ClassOp/DFun selection]
644                 -- See also note [Single-method classes]
645              dfun_id_w_fun = dfun_id  
646                              `setIdUnfolding`  mkDFunUnfolding dfun_ty (sc_args ++ meth_args)
647                              `setInlinePragma` dfunInlinePragma
648              meth_args = map (DFunPolyArg . Var) meth_ids
649
650              main_bind = AbsBinds { abs_tvs = inst_tyvars
651                                   , abs_ev_vars = dfun_ev_vars
652                                   , abs_exports = [(inst_tyvars, dfun_id_w_fun, self_dict,
653                                                     SpecPrags [] {- spec_inst_prags -})]
654                                   , abs_ev_binds = emptyTcEvBinds
655                                   , abs_binds = unitBag dict_bind }
656
657        ; return (unitBag (L loc main_bind) `unionBags`
658                  unionManyBags sc_binds    `unionBags`
659                  listToBag meth_binds)
660        }
661  where
662    skol_info = InstSkol         -- See Note [Subtle interaction of recursion and overlap]
663    dfun_ty   = idType dfun_id
664    dfun_id   = instanceDFunId ispec
665    loc       = getSrcSpan dfun_id
666
667 ------------------------------
668 tcSuperClass :: Int -> [EvVar] -> PredType -> TcM (LHsBinds Id, Id, DFunArg CoreExpr)
669 tcSuperClass n_ty_args ev_vars pred
670   | Just (ev, i) <- find n_ty_args ev_vars
671   = return (emptyBag, ev, DFunLamArg i)
672   | otherwise
673   = ASSERT2( isEmptyVarSet (tyVarsOfPred pred), ppr pred)
674     do { sc_dict  <- newWantedEvVar pred
675        ; loc      <- getCtLoc ScOrigin
676        ; ev_binds <- simplifyTop (unitBag (WcEvVar (WantedEvVar sc_dict loc)))
677        ; let ev_wrap = WpLet (EvBinds ev_binds)
678              sc_bind = mkVarBind sc_dict (noLoc $ (wrapId ev_wrap sc_dict))
679        ; return (unitBag sc_bind, sc_dict, DFunConstArg (Var sc_dict)) }
680            -- It's very important to solve the superclass constraint *in isolation*
681            -- so that it isn't generated by superclass selection from something else
682            -- We then generate the (also rather degenerate) top-level binding:
683            --      sc_dict = let sc_dict = <blah> in sc_dict
684            -- where <blah> is generated by solving the implication constraint
685   where
686     find _ [] = Nothing
687     find i (ev:evs) | pred `tcEqPred` evVarPred ev = Just (ev, i)
688                     | otherwise                    = find (i+1) evs
689
690 ------------------------------
691 tcSpecInstPrags :: DFunId -> InstBindings Name
692                 -> TcM ([Located TcSpecPrag], PragFun)
693 tcSpecInstPrags _ (NewTypeDerived {})
694   = return ([], \_ -> [])
695 tcSpecInstPrags dfun_id (VanillaInst binds uprags _)
696   = do { spec_inst_prags <- mapM (wrapLocM (tcSpecInst dfun_id)) $
697                             filter isSpecInstLSig uprags
698              -- The filter removes the pragmas for methods
699        ; return (spec_inst_prags, mkPragFun uprags binds) }
700 \end{code}
701
702 Note [Silent Superclass Arguments]
703 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
704 Consider the following (extreme) situation:
705         class C a => D a where ...
706         instance D [a] => D [a] where ...
707 Although this looks wrong (assume D [a] to prove D [a]), it is only a
708 more extreme case of what happens with recursive dictionaries.
709
710 To implement the dfun we must generate code for the superclass C [a],
711 which we can get by superclass selection from the supplied argument!
712 So we’d generate:
713        dfun :: forall a. D [a] -> D [a]
714        dfun = \d::D [a] -> MkD (scsel d) ..
715
716 However this means that if we later encounter a situation where
717 we have a [Wanted] dw::D [a] we could solve it thus:
718      dw := dfun dw
719 Although recursive, this binding would pass the TcSMonadisGoodRecEv
720 check because it appears as guarded.  But in reality, it will make a
721 bottom superclass. The trouble is that isGoodRecEv can't "see" the
722 superclass-selection inside dfun.
723
724 Our solution to this problem is to change the way ‘dfuns’ are created
725 for instances, so that we pass as first arguments to the dfun some
726 ``silent superclass arguments’’, which are the immediate superclasses
727 of the dictionary we are trying to construct. In our example:
728        dfun :: forall a. (C [a], D [a] -> D [a]
729        dfun = \(dc::C [a]) (dd::D [a]) -> DOrd dc ...
730
731 This gives us:
732
733      -----------------------------------------------------------
734      DFun Superclass Invariant
735      ~~~~~~~~~~~~~~~~~~~~~~~~
736      In the body of a DFun, every superclass argument to the
737      returned dictionary is
738        either   * one of the arguments of the DFun,
739        or       * constant, bound at top level
740      -----------------------------------------------------------
741
742 This means that no superclass is hidden inside a dfun application, so
743 the counting argument in isGoodRecEv (more dfun calls than superclass
744 selections) works correctly.
745
746 The extra arguments required to satisfy the DFun Superclass Invariant
747 always come first, and are called the "silent" arguments.  DFun types
748 are built (only) by MkId.mkDictFunId, so that is where we decide
749 what silent arguments are to be added.
750
751 This net effect is that it is safe to treat a dfun application as
752 wrapping a dictionary constructor around its arguments (in particular,
753 a dfun never picks superclasses from the arguments under the dictionary
754 constructor).
755
756 In our example, if we had  [Wanted] dw :: D [a] we would get via the instance:
757     dw := dfun d1 d2
758     [Wanted] (d1 :: C [a])
759     [Wanted] (d2 :: D [a])
760     [Derived] (d :: D [a])
761     [Derived] (scd :: C [a])   scd  := scsel d
762     [Derived] (scd2 :: C [a])  scd2 := scsel d2
763
764 And now, though we *can* solve: 
765      d2 := dw
766 we will get an isGoodRecEv failure when we try to solve:
767     d1 := scsel d 
768  or
769     d1 := scsel d2 
770
771 Test case SCLoop tests this fix. 
772          
773 Note [SPECIALISE instance pragmas]
774 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
775 Consider
776
777    instance (Ix a, Ix b) => Ix (a,b) where
778      {-# SPECIALISE instance Ix (Int,Int) #-}
779      range (x,y) = ...
780
781 We do *not* want to make a specialised version of the dictionary
782 function.  Rather, we want specialised versions of each method.
783 Thus we should generate something like this:
784
785   $dfIx :: (Ix a, Ix x) => Ix (a,b)
786   {- DFUN [$crange, ...] -}
787   $dfIx da db = Ix ($crange da db) (...other methods...)
788
789   $dfIxPair :: (Ix a, Ix x) => Ix (a,b)
790   {- DFUN [$crangePair, ...] -}
791   $dfIxPair = Ix ($crangePair da db) (...other methods...)
792
793   $crange :: (Ix a, Ix b) -> ((a,b),(a,b)) -> [(a,b)]
794   {-# SPECIALISE $crange :: ((Int,Int),(Int,Int)) -> [(Int,Int)] #-}
795   $crange da db = <blah>
796
797   {-# RULE  range ($dfIx da db) = $crange da db #-}
798
799 Note that  
800
801   * The RULE is unaffected by the specialisation.  We don't want to
802     specialise $dfIx, because then it would need a specialised RULE
803     which is a pain.  The single RULE works fine at all specialisations.
804     See Note [How instance declarations are translated] above
805
806   * Instead, we want to specialise the *method*, $crange
807
808 In practice, rather than faking up a SPECIALISE pragama for each
809 method (which is painful, since we'd have to figure out its
810 specialised type), we call tcSpecPrag *as if* were going to specialise
811 $dfIx -- you can see that in the call to tcSpecInst.  That generates a
812 SpecPrag which, as it turns out, can be used unchanged for each method.
813 The "it turns out" bit is delicate, but it works fine!
814
815 \begin{code}
816 tcSpecInst :: Id -> Sig Name -> TcM TcSpecPrag
817 tcSpecInst dfun_id prag@(SpecInstSig hs_ty) 
818   = addErrCtxt (spec_ctxt prag) $
819     do  { let name = idName dfun_id
820         ; (tyvars, theta, clas, tys) <- tcHsInstHead hs_ty
821         ; let (_, spec_dfun_ty) = mkDictFunTy tyvars theta clas tys
822
823         ; co_fn <- tcSubType (SpecPragOrigin name) (SigSkol SpecInstCtxt)
824                              (idType dfun_id) spec_dfun_ty
825         ; return (SpecPrag dfun_id co_fn defaultInlinePragma) }
826   where
827     spec_ctxt prag = hang (ptext (sLit "In the SPECIALISE pragma")) 2 (ppr prag)
828
829 tcSpecInst _  _ = panic "tcSpecInst"
830 \end{code}
831
832 %************************************************************************
833 %*                                                                      *
834       Type-checking an instance method
835 %*                                                                      *
836 %************************************************************************
837
838 tcInstanceMethod
839 - Make the method bindings, as a [(NonRec, HsBinds)], one per method
840 - Remembering to use fresh Name (the instance method Name) as the binder
841 - Bring the instance method Ids into scope, for the benefit of tcInstSig
842 - Use sig_fn mapping instance method Name -> instance tyvars
843 - Ditto prag_fn
844 - Use tcValBinds to do the checking
845
846 \begin{code}
847 tcInstanceMethods :: DFunId -> Class -> [TcTyVar]
848                   -> [EvVar]
849                   -> [TcType]
850                   -> ([Located TcSpecPrag], PragFun)
851                   -> [(Id, DefMeth)]
852                   -> InstBindings Name 
853                   -> TcM ([Id], [LHsBind Id])
854         -- The returned inst_meth_ids all have types starting
855         --      forall tvs. theta => ...
856 tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys 
857                   (spec_inst_prags, prag_fn)
858                   op_items (VanillaInst binds _ standalone_deriv)
859   = mapAndUnzipM tc_item op_items
860   where
861     ----------------------
862     tc_item :: (Id, DefMeth) -> TcM (Id, LHsBind Id)
863     tc_item (sel_id, dm_info)
864       = case findMethodBind (idName sel_id) binds of
865             Just user_bind -> tc_body sel_id standalone_deriv user_bind
866             Nothing        -> tc_default sel_id dm_info
867
868     ----------------------
869     tc_body :: Id -> Bool -> LHsBind Name -> TcM (TcId, LHsBind Id)
870     tc_body sel_id generated_code rn_bind 
871       = add_meth_ctxt sel_id generated_code rn_bind $
872         do { (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars 
873                                                    inst_tys sel_id
874            ; let prags = prag_fn (idName sel_id)
875            ; meth_id1 <- addInlinePrags meth_id prags
876            ; spec_prags <- tcSpecPrags meth_id1 prags
877            ; bind <- tcInstanceMethodBody InstSkol
878                           tyvars dfun_ev_vars
879                           meth_id1 local_meth_id meth_sig_fn 
880                           (mk_meth_spec_prags meth_id1 spec_prags)
881                           rn_bind 
882            ; return (meth_id1, bind) }
883
884     ----------------------
885     tc_default :: Id -> DefMeth -> TcM (TcId, LHsBind Id)
886     tc_default sel_id GenDefMeth    -- Derivable type classes stuff
887       = do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id
888            ; tc_body sel_id False {- Not generated code? -} meth_bind }
889           
890     tc_default sel_id NoDefMeth     -- No default method at all
891       = do { warnMissingMethod sel_id
892            ; (meth_id, _) <- mkMethIds clas tyvars dfun_ev_vars 
893                                          inst_tys sel_id
894            ; return (meth_id, mkVarBind meth_id $ 
895                               mkLHsWrap lam_wrapper error_rhs) }
896       where
897         error_rhs    = L loc $ HsApp error_fun error_msg
898         error_fun    = L loc $ wrapId (WpTyApp meth_tau) nO_METHOD_BINDING_ERROR_ID
899         error_msg    = L loc (HsLit (HsStringPrim (mkFastString error_string)))
900         meth_tau     = funResultTy (applyTys (idType sel_id) inst_tys)
901         error_string = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
902         lam_wrapper  = mkWpTyLams tyvars <.> mkWpLams dfun_ev_vars
903
904     tc_default sel_id (DefMeth dm_name) -- A polymorphic default method
905       = do {   -- Build the typechecked version directly, 
906                  -- without calling typecheck_method; 
907                  -- see Note [Default methods in instances]
908                  -- Generate   /\as.\ds. let self = df as ds
909                  --                      in $dm inst_tys self
910                  -- The 'let' is necessary only because HsSyn doesn't allow
911                  -- you to apply a function to a dictionary *expression*.
912
913            ; self_dict <- newEvVar (ClassP clas inst_tys)
914            ; let self_ev_bind = EvBind self_dict $
915                                 EvDFunApp dfun_id (mkTyVarTys tyvars) dfun_ev_vars
916
917            ; (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars 
918                                                    inst_tys sel_id
919            ; dm_id <- tcLookupId dm_name
920            ; let dm_inline_prag = idInlinePragma dm_id
921                  rhs = HsWrap (mkWpEvVarApps [self_dict] <.> mkWpTyApps inst_tys) $
922                          HsVar dm_id 
923
924                  meth_bind = L loc $ VarBind { var_id = local_meth_id
925                                              , var_rhs = L loc rhs 
926                                              , var_inline = False }
927                  meth_id1 = meth_id `setInlinePragma` dm_inline_prag
928                             -- Copy the inline pragma (if any) from the default
929                             -- method to this version. Note [INLINE and default methods]
930                             
931                  bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars =  dfun_ev_vars
932                                  , abs_exports = [( tyvars, meth_id1, local_meth_id
933                                                   , mk_meth_spec_prags meth_id1 [])]
934                                  , abs_ev_binds = EvBinds (unitBag self_ev_bind)
935                                  , abs_binds    = unitBag meth_bind }
936              -- Default methods in an instance declaration can't have their own 
937              -- INLINE or SPECIALISE pragmas. It'd be possible to allow them, but
938              -- currently they are rejected with 
939              --           "INLINE pragma lacks an accompanying binding"
940
941            ; return (meth_id1, L loc bind) } 
942
943     ----------------------
944     mk_meth_spec_prags :: Id -> [LTcSpecPrag] -> TcSpecPrags
945         -- Adapt the SPECIALISE pragmas to work for this method Id
946         -- There are two sources: 
947         --   * spec_inst_prags: {-# SPECIALISE instance :: <blah> #-}
948         --     These ones have the dfun inside, but [perhaps surprisingly] 
949         --     the correct wrapper
950         --   * spec_prags_for_me: {-# SPECIALISE op :: <blah> #-}
951     mk_meth_spec_prags meth_id spec_prags_for_me
952       = SpecPrags (spec_prags_for_me ++ 
953                    [ L loc (SpecPrag meth_id wrap inl)
954                    | L loc (SpecPrag _ wrap inl) <- spec_inst_prags])
955    
956     loc = getSrcSpan dfun_id
957     meth_sig_fn _ = Just ([],loc)       -- The 'Just' says "yes, there's a type sig"
958         -- But there are no scoped type variables from local_method_id
959         -- Only the ones from the instance decl itself, which are already
960         -- in scope.  Example:
961         --      class C a where { op :: forall b. Eq b => ... }
962         --      instance C [c] where { op = <rhs> }
963         -- In <rhs>, 'c' is scope but 'b' is not!
964
965         -- For instance decls that come from standalone deriving clauses
966         -- we want to print out the full source code if there's an error
967         -- because otherwise the user won't see the code at all
968     add_meth_ctxt sel_id generated_code rn_bind thing 
969       | generated_code = addLandmarkErrCtxt (derivBindCtxt sel_id clas inst_tys rn_bind) thing
970       | otherwise      = thing
971
972
973 tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys 
974                   _ op_items (NewTypeDerived coi _)
975
976 -- Running example:
977 --   class Show b => Foo a b where
978 --     op :: a -> b -> b
979 --   newtype N a = MkN (Tree [a]) 
980 --   deriving instance (Show p, Foo Int p) => Foo Int (N p)
981 --               -- NB: standalone deriving clause means
982 --               --     that the contex is user-specified
983 -- Hence op :: forall a b. Foo a b => a -> b -> b
984 --
985 -- We're going to make an instance like
986 --   instance (Show p, Foo Int p) => Foo Int (N p)
987 --      op = $copT
988 --
989 --   $copT :: forall p. (Show p, Foo Int p) => Int -> N p -> N p
990 --   $copT p (d1:Show p) (d2:Foo Int p) 
991 --     = op Int (Tree [p]) rep_d |> op_co
992 --     where 
993 --       rep_d :: Foo Int (Tree [p]) = ...d1...d2...
994 --       op_co :: (Int -> Tree [p] -> Tree [p]) ~ (Int -> T p -> T p)
995 -- We get op_co by substituting [Int/a] and [co/b] in type for op
996 -- where co : [p] ~ T p
997 --
998 -- Notice that the dictionary bindings "..d1..d2.." must be generated
999 -- by the constraint solver, since the <context> may be
1000 -- user-specified.
1001
1002   = do { rep_d_stuff <- checkConstraints InstSkol tyvars dfun_ev_vars $
1003                         emitWanted ScOrigin rep_pred
1004                          
1005        ; mapAndUnzipM (tc_item rep_d_stuff) op_items }
1006   where
1007      loc = getSrcSpan dfun_id
1008
1009      inst_tvs = fst (tcSplitForAllTys (idType dfun_id))
1010      Just (init_inst_tys, _) = snocView inst_tys
1011      rep_ty   = fst (coercionKind co)  -- [p]
1012      rep_pred = mkClassPred clas (init_inst_tys ++ [rep_ty])
1013
1014      -- co : [p] ~ T p
1015      co = substTyWith inst_tvs (mkTyVarTys tyvars) $
1016           case coi of { IdCo ty -> ty ;
1017                         ACo co  -> mkSymCoercion co }
1018
1019      ----------------
1020      tc_item :: (TcEvBinds, EvVar) -> (Id, DefMeth) -> TcM (TcId, LHsBind TcId)
1021      tc_item (rep_ev_binds, rep_d) (sel_id, _)
1022        = do { (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars 
1023                                                     inst_tys sel_id
1024
1025             ; let meth_rhs  = wrapId (mk_op_wrapper sel_id rep_d) sel_id
1026                   meth_bind = VarBind { var_id = local_meth_id
1027                                       , var_rhs = L loc meth_rhs
1028                                       , var_inline = False }
1029
1030                   bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars
1031                                    , abs_exports = [(tyvars, meth_id, 
1032                                                      local_meth_id, noSpecPrags)]
1033                                    , abs_ev_binds = rep_ev_binds
1034                                    , abs_binds = unitBag $ L loc meth_bind }
1035
1036             ; return (meth_id, L loc bind) }
1037
1038      ----------------
1039      mk_op_wrapper :: Id -> EvVar -> HsWrapper
1040      mk_op_wrapper sel_id rep_d 
1041        = WpCast (substTyWith sel_tvs (init_inst_tys ++ [co]) local_meth_ty)
1042          <.> WpEvApp (EvId rep_d)
1043          <.> mkWpTyApps (init_inst_tys ++ [rep_ty]) 
1044        where
1045          (sel_tvs, sel_rho) = tcSplitForAllTys (idType sel_id)
1046          (_, local_meth_ty) = tcSplitPredFunTy_maybe sel_rho
1047                               `orElse` pprPanic "tcInstanceMethods" (ppr sel_id)
1048
1049 ----------------------
1050 mkMethIds :: Class -> [TcTyVar] -> [EvVar] -> [TcType] -> Id -> TcM (TcId, TcId)
1051 mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id
1052   = do  { uniq <- newUnique
1053         ; let meth_name = mkDerivedInternalName mkClassOpAuxOcc uniq sel_name
1054         ; local_meth_name <- newLocalName sel_name
1055                   -- Base the local_meth_name on the selector name, becuase
1056                   -- type errors from tcInstanceMethodBody come from here
1057
1058         ; let meth_id       = mkLocalId meth_name meth_ty
1059               local_meth_id = mkLocalId local_meth_name local_meth_ty
1060         ; return (meth_id, local_meth_id) }
1061   where
1062     local_meth_ty = instantiateMethod clas sel_id inst_tys
1063     meth_ty = mkForAllTys tyvars $ mkPiTypes dfun_ev_vars local_meth_ty
1064     sel_name = idName sel_id
1065
1066 ----------------------
1067 wrapId :: HsWrapper -> id -> HsExpr id
1068 wrapId wrapper id = mkHsWrap wrapper (HsVar id)
1069
1070 derivBindCtxt :: Id -> Class -> [Type ] -> LHsBind Name -> SDoc
1071 derivBindCtxt sel_id clas tys _bind
1072    = vcat [ ptext (sLit "When typechecking the code for ") <+> quotes (ppr sel_id)
1073           , nest 2 (ptext (sLit "in a standalone derived instance for")
1074                     <+> quotes (pprClassPred clas tys) <> colon)
1075           , nest 2 $ ptext (sLit "To see the code I am typechecking, use -ddump-deriv") ]
1076
1077 -- Too voluminous
1078 --        , nest 2 $ pprSetDepth AllTheWay $ ppr bind ]
1079
1080 warnMissingMethod :: Id -> TcM ()
1081 warnMissingMethod sel_id
1082   = do { warn <- doptM Opt_WarnMissingMethods           
1083        ; warnTc (warn  -- Warn only if -fwarn-missing-methods
1084                  && not (startsWithUnderscore (getOccName sel_id)))
1085                                         -- Don't warn about _foo methods
1086                 (ptext (sLit "No explicit method nor default method for")
1087                  <+> quotes (ppr sel_id)) }
1088 \end{code}
1089
1090 Note [Export helper functions]
1091 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1092 We arrange to export the "helper functions" of an instance declaration,
1093 so that they are not subject to preInlineUnconditionally, even if their
1094 RHS is trivial.  Reason: they are mentioned in the DFunUnfolding of
1095 the dict fun as Ids, not as CoreExprs, so we can't substitute a 
1096 non-variable for them.
1097
1098 We could change this by making DFunUnfoldings have CoreExprs, but it
1099 seems a bit simpler this way.
1100
1101 Note [Default methods in instances]
1102 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1103 Consider this
1104
1105    class Baz v x where
1106       foo :: x -> x
1107       foo y = <blah>
1108
1109    instance Baz Int Int
1110
1111 From the class decl we get
1112
1113    $dmfoo :: forall v x. Baz v x => x -> x
1114    $dmfoo y = <blah>
1115
1116 Notice that the type is ambiguous.  That's fine, though. The instance
1117 decl generates
1118
1119    $dBazIntInt = MkBaz fooIntInt
1120    fooIntInt = $dmfoo Int Int $dBazIntInt
1121
1122 BUT this does mean we must generate the dictionary translation of
1123 fooIntInt directly, rather than generating source-code and
1124 type-checking it.  That was the bug in Trac #1061. In any case it's
1125 less work to generate the translated version!
1126
1127 Note [INLINE and default methods]
1128 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1129 Default methods need special case.  They are supposed to behave rather like
1130 macros.  For exmample
1131
1132   class Foo a where
1133     op1, op2 :: Bool -> a -> a
1134
1135     {-# INLINE op1 #-}
1136     op1 b x = op2 (not b) x
1137
1138   instance Foo Int where
1139     -- op1 via default method
1140     op2 b x = <blah>
1141    
1142 The instance declaration should behave
1143
1144    just as if 'op1' had been defined with the
1145    code, and INLINE pragma, from its original
1146    definition. 
1147
1148 That is, just as if you'd written
1149
1150   instance Foo Int where
1151     op2 b x = <blah>
1152
1153     {-# INLINE op1 #-}
1154     op1 b x = op2 (not b) x
1155
1156 So for the above example we generate:
1157
1158
1159   {-# INLINE $dmop1 #-}
1160   -- $dmop1 has an InlineCompulsory unfolding
1161   $dmop1 d b x = op2 d (not b) x
1162
1163   $fFooInt = MkD $cop1 $cop2
1164
1165   {-# INLINE $cop1 #-}
1166   $cop1 = $dmop1 $fFooInt
1167
1168   $cop2 = <blah>
1169
1170 Note carefullly:
1171
1172 * We *copy* any INLINE pragma from the default method $dmop1 to the
1173   instance $cop1.  Otherwise we'll just inline the former in the
1174   latter and stop, which isn't what the user expected
1175
1176 * Regardless of its pragma, we give the default method an 
1177   unfolding with an InlineCompulsory source. That means
1178   that it'll be inlined at every use site, notably in
1179   each instance declaration, such as $cop1.  This inlining
1180   must happen even though 
1181     a) $dmop1 is not saturated in $cop1
1182     b) $cop1 itself has an INLINE pragma
1183
1184   It's vital that $dmop1 *is* inlined in this way, to allow the mutual
1185   recursion between $fooInt and $cop1 to be broken
1186
1187 * To communicate the need for an InlineCompulsory to the desugarer
1188   (which makes the Unfoldings), we use the IsDefaultMethod constructor
1189   in TcSpecPrags.
1190
1191
1192 %************************************************************************
1193 %*                                                                      *
1194 \subsection{Error messages}
1195 %*                                                                      *
1196 %************************************************************************
1197
1198 \begin{code}
1199 instDeclCtxt1 :: LHsType Name -> SDoc
1200 instDeclCtxt1 hs_inst_ty
1201   = inst_decl_ctxt (case unLoc hs_inst_ty of
1202                         HsForAllTy _ _ _ (L _ (HsPredTy pred)) -> ppr pred
1203                         HsPredTy pred                    -> ppr pred
1204                         _                                -> ppr hs_inst_ty)     -- Don't expect this
1205 instDeclCtxt2 :: Type -> SDoc
1206 instDeclCtxt2 dfun_ty
1207   = inst_decl_ctxt (ppr (mkClassPred cls tys))
1208   where
1209     (_,cls,tys) = tcSplitDFunTy dfun_ty
1210
1211 inst_decl_ctxt :: SDoc -> SDoc
1212 inst_decl_ctxt doc = ptext (sLit "In the instance declaration for") <+> quotes doc
1213
1214 atInstCtxt :: Name -> SDoc
1215 atInstCtxt name = ptext (sLit "In the associated type instance for") <+>
1216                   quotes (ppr name)
1217
1218 mustBeVarArgErr :: Type -> SDoc
1219 mustBeVarArgErr ty =
1220   sep [ ptext (sLit "Arguments that do not correspond to a class parameter") <+>
1221         ptext (sLit "must be variables")
1222       , ptext (sLit "Instead of a variable, found") <+> ppr ty
1223       ]
1224
1225 wrongATArgErr :: Type -> Type -> SDoc
1226 wrongATArgErr ty instTy =
1227   sep [ ptext (sLit "Type indexes must match class instance head")
1228       , ptext (sLit "Found") <+> quotes (ppr ty)
1229         <+> ptext (sLit "but expected") <+> quotes (ppr instTy)
1230       ]
1231 \end{code}