Do dependency analysis when kind-checking type declarations
[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 use a different 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 a
192 top-level axiom. The "constructor" MkC expands to a cast, as does the
193 class-op selector.
194
195    axiom Co:C a :: C a ~ (a->a)
196
197    op :: forall a. C a -> (a -> a)
198    op a d = d |> (Co:C a)
199
200    MkC :: forall a. (a->a) -> C a
201    MkC = /\a.\op. op |> (sym Co:C a)
202
203 The clever RULE stuff doesn't work now, because ($df a d) isn't
204 a constructor application, so exprIsConApp_maybe won't return 
205 Just <blah>.
206
207 Instead, we simply rely on the fact that casts are cheap:
208
209    $df :: forall a. C a => C [a]
210    {-# INLINE df #}  -- NB: INLINE this
211    $df = /\a. \d. MkC [a] ($cop_list a d)
212        = $cop_list |> forall a. C a -> (sym (Co:C [a]))
213
214    $cop_list :: forall a. C a => [a] -> [a]
215    $cop_list = <blah>
216
217 So if we see
218    (op ($df a d))
219 we'll inline 'op' and '$df', since both are simply casts, and
220 good things happen.
221
222 Why do we use this different strategy?  Because otherwise we
223 end up with non-inlined dictionaries that look like
224     $df = $cop |> blah
225 which adds an extra indirection to every use, which seems stupid.  See
226 Trac #4138 for an example (although the regression reported there
227 wasn't due to the indirction).
228
229 There is an awkward wrinkle though: we want to be very 
230 careful when we have
231     instance C a => C [a] where
232       {-# INLINE op #-}
233       op = ...
234 then we'll get an INLINE pragma on $cop_list but it's important that
235 $cop_list only inlines when it's applied to *two* arguments (the
236 dictionary and the list argument).  So we nust not eta-expand $df
237 above.  We ensure that this doesn't happen by putting an INLINE 
238 pragma on the dfun itself; after all, it ends up being just a cast.
239
240 There is one more dark corner to the INLINE story, even more deeply 
241 buried.  Consider this (Trac #3772):
242
243     class DeepSeq a => C a where
244       gen :: Int -> a
245
246     instance C a => C [a] where
247       gen n = ...
248
249     class DeepSeq a where
250       deepSeq :: a -> b -> b
251
252     instance DeepSeq a => DeepSeq [a] where
253       {-# INLINE deepSeq #-}
254       deepSeq xs b = foldr deepSeq b xs
255
256 That gives rise to these defns:
257
258     $cdeepSeq :: DeepSeq a -> [a] -> b -> b
259     -- User INLINE( 3 args )!
260     $cdeepSeq a (d:DS a) b (x:[a]) (y:b) = ...
261
262     $fDeepSeq[] :: DeepSeq a -> DeepSeq [a]
263     -- DFun (with auto INLINE pragma)
264     $fDeepSeq[] a d = $cdeepSeq a d |> blah
265
266     $cp1 a d :: C a => DeepSep [a]
267     -- We don't want to eta-expand this, lest
268     -- $cdeepSeq gets inlined in it!
269     $cp1 a d = $fDeepSep[] a (scsel a d)
270
271     $fC[] :: C a => C [a]
272     -- Ordinary DFun
273     $fC[] a d = MkC ($cp1 a d) ($cgen a d)
274
275 Here $cp1 is the code that generates the superclass for C [a].  The
276 issue is this: we must not eta-expand $cp1 either, or else $fDeepSeq[]
277 and then $cdeepSeq will inline there, which is definitely wrong.  Like
278 on the dfun, we solve this by adding an INLINE pragma to $cp1.
279
280 Note [Subtle interaction of recursion and overlap]
281 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
282 Consider this
283   class C a where { op1,op2 :: a -> a }
284   instance C a => C [a] where
285     op1 x = op2 x ++ op2 x
286     op2 x = ...
287   instance C [Int] where
288     ...
289
290 When type-checking the C [a] instance, we need a C [a] dictionary (for
291 the call of op2).  If we look up in the instance environment, we find
292 an overlap.  And in *general* the right thing is to complain (see Note
293 [Overlapping instances] in InstEnv).  But in *this* case it's wrong to
294 complain, because we just want to delegate to the op2 of this same
295 instance.  
296
297 Why is this justified?  Because we generate a (C [a]) constraint in 
298 a context in which 'a' cannot be instantiated to anything that matches
299 other overlapping instances, or else we would not be excecuting this
300 version of op1 in the first place.
301
302 It might even be a bit disguised:
303
304   nullFail :: C [a] => [a] -> [a]
305   nullFail x = op2 x ++ op2 x
306
307   instance C a => C [a] where
308     op1 x = nullFail x
309
310 Precisely this is used in package 'regex-base', module Context.hs.
311 See the overlapping instances for RegexContext, and the fact that they
312 call 'nullFail' just like the example above.  The DoCon package also
313 does the same thing; it shows up in module Fraction.hs
314
315 Conclusion: when typechecking the methods in a C [a] instance, we want to
316 treat the 'a' as an *existential* type variable, in the sense described
317 by Note [Binding when looking up instances].  That is why isOverlappableTyVar
318 responds True to an InstSkol, which is the kind of skolem we use in
319 tcInstDecl2.
320
321
322 Note [Tricky type variable scoping]
323 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
324 In our example
325         class C a where
326            op1, op2 :: Ix b => a -> b -> b
327            op2 = <dm-rhs>
328
329         instance C a => C [a]
330            {-# INLINE [2] op1 #-}
331            op1 = <rhs>
332
333 note that 'a' and 'b' are *both* in scope in <dm-rhs>, but only 'a' is
334 in scope in <rhs>.  In particular, we must make sure that 'b' is in
335 scope when typechecking <dm-rhs>.  This is achieved by subFunTys,
336 which brings appropriate tyvars into scope. This happens for both
337 <dm-rhs> and for <rhs>, but that doesn't matter: the *renamer* will have
338 complained if 'b' is mentioned in <rhs>.
339
340
341
342 %************************************************************************
343 %*                                                                      *
344 \subsection{Extracting instance decls}
345 %*                                                                      *
346 %************************************************************************
347
348 Gather up the instance declarations from their various sources
349
350 \begin{code}
351 tcInstDecls1    -- Deal with both source-code and imported instance decls
352    :: [LTyClDecl Name]          -- For deriving stuff
353    -> [LInstDecl Name]          -- Source code instance decls
354    -> [LDerivDecl Name]         -- Source code stand-alone deriving decls
355    -> TcM (TcGblEnv,            -- The full inst env
356            [InstInfo Name],     -- Source-code instance decls to process;
357                                 -- contains all dfuns for this module
358            HsValBinds Name)     -- Supporting bindings for derived instances
359
360 tcInstDecls1 tycl_decls inst_decls deriv_decls
361   = checkNoErrs $
362     do {        -- Stop if addInstInfos etc discovers any errors
363                 -- (they recover, so that we get more than one error each
364                 -- round)
365
366                 -- (1) Do class and family instance declarations
367        ; idx_tycons        <- mapAndRecoverM (tcFamInstDecl TopLevel) $
368                               filter (isFamInstDecl . unLoc) tycl_decls 
369        ; local_info_tycons <- mapAndRecoverM tcLocalInstDecl1  inst_decls
370
371        ; let { (local_info,
372                 at_tycons_s)   = unzip local_info_tycons
373              ; at_idx_tycons   = concat at_tycons_s ++ idx_tycons
374              ; clas_decls      = filter (isClassDecl . unLoc) tycl_decls
375              ; implicit_things = concatMap implicitTyThings at_idx_tycons
376              ; aux_binds       = mkRecSelBinds at_idx_tycons
377              }
378
379                 -- (2) Add the tycons of indexed types and their implicit
380                 --     tythings to the global environment
381        ; tcExtendGlobalEnv (at_idx_tycons ++ implicit_things) $ do {
382
383                 -- (3) Instances from generic class declarations
384        ; generic_inst_info <- getGenericInstances clas_decls
385
386                 -- Next, construct the instance environment so far, consisting
387                 -- of
388                 --   (a) local instance decls
389                 --   (b) generic instances
390                 --   (c) local family instance decls
391        ; addInsts local_info         $
392          addInsts generic_inst_info  $
393          addFamInsts at_idx_tycons   $ do {
394
395                 -- (4) Compute instances from "deriving" clauses;
396                 -- This stuff computes a context for the derived instance
397                 -- decl, so it needs to know about all the instances possible
398                 -- NB: class instance declarations can contain derivings as
399                 --     part of associated data type declarations
400          failIfErrsM            -- If the addInsts stuff gave any errors, don't
401                                 -- try the deriving stuff, becuase that may give
402                                 -- more errors still
403        ; (deriv_inst_info, deriv_binds, deriv_dus) 
404               <- tcDeriving tycl_decls inst_decls deriv_decls
405        ; gbl_env <- addInsts deriv_inst_info getGblEnv
406        ; return ( addTcgDUs gbl_env deriv_dus,
407                   generic_inst_info ++ deriv_inst_info ++ local_info,
408                   aux_binds `plusHsValBinds` deriv_binds)
409     }}}
410
411 addInsts :: [InstInfo Name] -> TcM a -> TcM a
412 addInsts infos thing_inside
413   = tcExtendLocalInstEnv (map iSpec infos) thing_inside
414
415 addFamInsts :: [TyThing] -> TcM a -> TcM a
416 addFamInsts tycons thing_inside
417   = tcExtendLocalFamInstEnv (map mkLocalFamInstTyThing tycons) thing_inside
418   where
419     mkLocalFamInstTyThing (ATyCon tycon) = mkLocalFamInst tycon
420     mkLocalFamInstTyThing tything        = pprPanic "TcInstDcls.addFamInsts"
421                                                     (ppr tything)
422 \end{code}
423
424 \begin{code}
425 tcLocalInstDecl1 :: LInstDecl Name
426                  -> TcM (InstInfo Name, [TyThing])
427         -- A source-file instance declaration
428         -- Type-check all the stuff before the "where"
429         --
430         -- We check for respectable instance type, and context
431 tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats))
432   = setSrcSpan loc                      $
433     addErrCtxt (instDeclCtxt1 poly_ty)  $
434
435     do  { is_boot <- tcIsHsBoot
436         ; checkTc (not is_boot || (isEmptyLHsBinds binds && null uprags))
437                   badBootDeclErr
438
439         ; (tyvars, theta, clas, inst_tys) <- tcHsInstHead poly_ty
440         ; checkValidInstance poly_ty tyvars theta clas inst_tys
441
442         -- Next, process any associated types.
443         ; idx_tycons <- recoverM (return []) $
444                      do { idx_tycons <- checkNoErrs $ 
445                                         mapAndRecoverM (tcFamInstDecl NotTopLevel) ats
446                         ; checkValidAndMissingATs clas (tyvars, inst_tys)
447                                                   (zip ats idx_tycons)
448                         ; return idx_tycons }
449
450         -- Finally, construct the Core representation of the instance.
451         -- (This no longer includes the associated types.)
452         ; dfun_name <- newDFunName clas inst_tys (getLoc poly_ty)
453                 -- Dfun location is that of instance *header*
454         ; overlap_flag <- getOverlapFlag
455         ; let (eq_theta,dict_theta) = partition isEqPred theta
456               theta'         = eq_theta ++ dict_theta
457               dfun           = mkDictFunId dfun_name tyvars theta' clas inst_tys
458               ispec          = mkLocalInstance dfun overlap_flag
459
460         ; return (InstInfo { iSpec  = ispec, iBinds = VanillaInst binds uprags False },
461                   idx_tycons)
462         }
463   where
464     -- We pass in the source form and the type checked form of the ATs.  We
465     -- really need the source form only to be able to produce more informative
466     -- error messages.
467     checkValidAndMissingATs :: Class
468                             -> ([TyVar], [TcType])     -- instance types
469                             -> [(LTyClDecl Name,       -- source form of AT
470                                  TyThing)]             -- Core form of AT
471                             -> TcM ()
472     checkValidAndMissingATs clas inst_tys ats
473       = do { -- Issue a warning for each class AT that is not defined in this
474              -- instance.
475            ; let class_ats   = map tyConName (classATs clas)
476                  defined_ats = listToNameSet . map (tcdName.unLoc.fst)  $ ats
477                  omitted     = filterOut (`elemNameSet` defined_ats) class_ats
478            ; warn <- doptM Opt_WarnMissingMethods
479            ; mapM_ (warnTc warn . omittedATWarn) omitted
480
481              -- Ensure that all AT indexes that correspond to class parameters
482              -- coincide with the types in the instance head.  All remaining
483              -- AT arguments must be variables.  Also raise an error for any
484              -- type instances that are not associated with this class.
485            ; mapM_ (checkIndexes clas inst_tys) ats
486            }
487
488     checkIndexes clas inst_tys (hsAT, ATyCon tycon)
489 -- !!!TODO: check that this does the Right Thing for indexed synonyms, too!
490       = checkIndexes' clas inst_tys hsAT
491                       (tyConTyVars tycon,
492                        snd . fromJust . tyConFamInst_maybe $ tycon)
493     checkIndexes _ _ _ = panic "checkIndexes"
494
495     checkIndexes' clas (instTvs, instTys) hsAT (atTvs, atTys)
496       = let atName = tcdName . unLoc $ hsAT
497         in
498         setSrcSpan (getLoc hsAT)       $
499         addErrCtxt (atInstCtxt atName) $
500         case find ((atName ==) . tyConName) (classATs clas) of
501           Nothing     -> addErrTc $ badATErr clas atName  -- not in this class
502           Just atycon ->
503                 -- The following is tricky!  We need to deal with three
504                 -- complications: (1) The AT possibly only uses a subset of
505                 -- the class parameters as indexes and those it uses may be in
506                 -- a different order; (2) the AT may have extra arguments,
507                 -- which must be type variables; and (3) variables in AT and
508                 -- instance head will be different `Name's even if their
509                 -- source lexemes are identical.
510                 --
511                 -- e.g.    class C a b c where 
512                 --           data D b a :: * -> *           -- NB (1) b a, omits c
513                 --         instance C [x] Bool Char where 
514                 --           data D Bool [x] v = MkD x [v]  -- NB (2) v
515                 --                -- NB (3) the x in 'instance C...' have differnt
516                 --                --        Names to x's in 'data D...'
517                 --
518                 -- Re (1), `poss' contains a permutation vector to extract the
519                 -- class parameters in the right order.
520                 --
521                 -- Re (2), we wrap the (permuted) class parameters in a Maybe
522                 -- type and use Nothing for any extra AT arguments.  (First
523                 -- equation of `checkIndex' below.)
524                 --
525                 -- Re (3), we replace any type variable in the AT parameters
526                 -- that has the same source lexeme as some variable in the
527                 -- instance types with the instance type variable sharing its
528                 -- source lexeme.
529                 --
530                 let poss :: [Int]
531                     -- For *associated* type families, gives the position
532                     -- of that 'TyVar' in the class argument list (0-indexed)
533                     -- e.g.  class C a b c where { type F c a :: *->* }
534                     --       Then we get Just [2,0]
535                     poss = catMaybes [ tv `elemIndex` classTyVars clas 
536                                      | tv <- tyConTyVars atycon]
537                        -- We will get Nothings for the "extra" type 
538                        -- variables in an associated data type
539                        -- e.g. class C a where { data D a :: *->* }
540                        -- here D gets arity 2 and has two tyvars
541
542                     relevantInstTys = map (instTys !!) poss
543                     instArgs        = map Just relevantInstTys ++
544                                       repeat Nothing  -- extra arguments
545                     renaming        = substSameTyVar atTvs instTvs
546                 in
547                 zipWithM_ checkIndex (substTys renaming atTys) instArgs
548
549     checkIndex ty Nothing
550       | isTyVarTy ty         = return ()
551       | otherwise            = addErrTc $ mustBeVarArgErr ty
552     checkIndex ty (Just instTy)
553       | ty `tcEqType` instTy = return ()
554       | otherwise            = addErrTc $ wrongATArgErr ty instTy
555
556     listToNameSet = addListToNameSet emptyNameSet
557
558     substSameTyVar []       _            = emptyTvSubst
559     substSameTyVar (tv:tvs) replacingTvs =
560       let replacement = case find (tv `sameLexeme`) replacingTvs of
561                         Nothing  -> mkTyVarTy tv
562                         Just rtv -> mkTyVarTy rtv
563           --
564           tv1 `sameLexeme` tv2 =
565             nameOccName (tyVarName tv1) == nameOccName (tyVarName tv2)
566       in
567       extendTvSubst (substSameTyVar tvs replacingTvs) tv replacement
568 \end{code}
569
570
571 %************************************************************************
572 %*                                                                      *
573       Type-checking instance declarations, pass 2
574 %*                                                                      *
575 %************************************************************************
576
577 \begin{code}
578 tcInstDecls2 :: [LTyClDecl Name] -> [InstInfo Name]
579              -> TcM (LHsBinds Id)
580 -- (a) From each class declaration,
581 --      generate any default-method bindings
582 -- (b) From each instance decl
583 --      generate the dfun binding
584
585 tcInstDecls2 tycl_decls inst_decls
586   = do  { -- (a) Default methods from class decls
587           let class_decls = filter (isClassDecl . unLoc) tycl_decls
588         ; dm_binds_s <- mapM tcClassDecl2 class_decls
589         ; let dm_binds = unionManyBags dm_binds_s
590                                     
591           -- (b) instance declarations
592         ; let dm_ids = collectHsBindsBinders dm_binds
593               -- Add the default method Ids (again)
594               -- See Note [Default methods and instances]
595         ; inst_binds_s <- tcExtendIdEnv dm_ids $
596                           mapM tcInstDecl2 inst_decls
597
598           -- Done
599         ; return (dm_binds `unionBags` unionManyBags inst_binds_s) }
600 \end{code}
601
602 See Note [Default methods and instances]
603 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
604 The default method Ids are already in the type environment (see Note
605 [Default method Ids and Template Haskell] in TcTyClsDcls), BUT they
606 don't have their InlinePragmas yet.  Usually that would not matter,
607 because the simplifier propagates information from binding site to
608 use.  But, unusually, when compiling instance decls we *copy* the
609 INLINE pragma from the default method to the method for that
610 particular operation (see Note [INLINE and default methods] below).
611
612 So right here in tcInstDecl2 we must re-extend the type envt with
613 the default method Ids replete with their INLINE pragmas.  Urk.
614
615 \begin{code}
616
617 tcInstDecl2 :: InstInfo Name -> TcM (LHsBinds Id)
618             -- Returns a binding for the dfun
619 tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
620   = recoverM (return emptyLHsBinds)             $
621     setSrcSpan loc                              $
622     addErrCtxt (instDeclCtxt2 (idType dfun_id)) $ 
623     do {  -- Instantiate the instance decl with skolem constants
624        ; (inst_tyvars, dfun_theta, inst_head) <- tcSkolSigType skol_info (idType dfun_id)
625        ; let (clas, inst_tys) = tcSplitDFunHead inst_head
626              (class_tyvars, sc_theta, _, op_items) = classBigSig clas
627              sc_theta' = substTheta (zipOpenTvSubst class_tyvars inst_tys) sc_theta
628              n_ty_args = length inst_tyvars
629              n_silent  = dfunNSilent dfun_id
630              (silent_theta, orig_theta) = splitAt n_silent dfun_theta
631
632        ; silent_ev_vars <- mapM newSilentGiven silent_theta
633        ; orig_ev_vars   <- newEvVars orig_theta
634        ; let dfun_ev_vars = silent_ev_vars ++ orig_ev_vars
635
636        ; (sc_binds, sc_dicts, sc_args)
637              <- mapAndUnzip3M (tcSuperClass n_ty_args dfun_ev_vars) sc_theta'
638
639        -- Check that any superclasses gotten from a silent arguemnt
640        -- can be deduced from the originally-specified dfun arguments
641        ; ct_loc <- getCtLoc ScOrigin
642        ; _ <- checkConstraints skol_info inst_tyvars orig_ev_vars $
643               emitConstraints $ listToBag $
644               [ WcEvVar (WantedEvVar sc ct_loc)
645               | sc <- sc_dicts, isSilentEvVar sc ]
646
647        -- Deal with 'SPECIALISE instance' pragmas
648        -- See Note [SPECIALISE instance pragmas]
649        ; spec_info <- tcSpecInstPrags dfun_id ibinds
650
651         -- Typecheck the methods
652        ; (meth_ids, meth_binds) 
653            <- tcExtendTyVarEnv inst_tyvars $
654                 -- The inst_tyvars scope over the 'where' part
655                 -- Those tyvars are inside the dfun_id's type, which is a bit
656                 -- bizarre, but OK so long as you realise it!
657               tcInstanceMethods dfun_id clas inst_tyvars dfun_ev_vars
658                                 inst_tys spec_info
659                                 op_items ibinds
660
661        -- Create the result bindings
662        ; self_dict <- newEvVar (ClassP clas inst_tys)
663        ; let class_tc      = classTyCon clas
664              [dict_constr] = tyConDataCons class_tc
665              dict_bind     = mkVarBind self_dict dict_rhs
666              dict_rhs      = foldl mk_app inst_constr $
667                              map HsVar sc_dicts ++ map (wrapId arg_wrapper) meth_ids
668              inst_constr   = L loc $ wrapId (mkWpTyApps inst_tys)
669                                             (dataConWrapId dict_constr)
670                      -- We don't produce a binding for the dict_constr; instead we
671                      -- rely on the simplifier to unfold this saturated application
672                      -- We do this rather than generate an HsCon directly, because
673                      -- it means that the special cases (e.g. dictionary with only one
674                      -- member) are dealt with by the common MkId.mkDataConWrapId 
675                      -- code rather than needing to be repeated here.
676
677              mk_app :: LHsExpr Id -> HsExpr Id -> LHsExpr Id
678              mk_app fun arg = L loc (HsApp fun (L loc arg))
679
680              arg_wrapper = mkWpEvVarApps dfun_ev_vars <.> mkWpTyApps (mkTyVarTys inst_tyvars)
681
682                 -- Do not inline the dfun; instead give it a magic DFunFunfolding
683                 -- See Note [ClassOp/DFun selection]
684                 -- See also note [Single-method classes]
685              dfun_id_w_fun
686                 | isNewTyCon class_tc
687                 = dfun_id `setInlinePragma` alwaysInlinePragma { inl_sat = Just 0 }
688                 | otherwise
689                 = dfun_id `setIdUnfolding`  mkDFunUnfolding dfun_ty (sc_args ++ meth_args)
690                           `setInlinePragma` dfunInlinePragma
691              meth_args = map (DFunPolyArg . Var) meth_ids
692
693              main_bind = AbsBinds { abs_tvs = inst_tyvars
694                                   , abs_ev_vars = dfun_ev_vars
695                                   , abs_exports = [(inst_tyvars, dfun_id_w_fun, self_dict,
696                                                     SpecPrags [] {- spec_inst_prags -})]
697                                   , abs_ev_binds = emptyTcEvBinds
698                                   , abs_binds = unitBag dict_bind }
699
700        ; return (unitBag (L loc main_bind) `unionBags`
701                  unionManyBags sc_binds    `unionBags`
702                  listToBag meth_binds)
703        }
704  where
705    skol_info = InstSkol         -- See Note [Subtle interaction of recursion and overlap]
706    dfun_ty   = idType dfun_id
707    dfun_id   = instanceDFunId ispec
708    loc       = getSrcSpan dfun_id
709
710 ------------------------------
711 tcSuperClass :: Int -> [EvVar] -> PredType -> TcM (LHsBinds Id, Id, DFunArg CoreExpr)
712 tcSuperClass n_ty_args ev_vars pred
713   | Just (ev, i) <- find n_ty_args ev_vars
714   = return (emptyBag, ev, DFunLamArg i)
715   | otherwise
716   = ASSERT2( isEmptyVarSet (tyVarsOfPred pred), ppr pred)
717     do { sc_dict  <- newWantedEvVar pred
718        ; loc      <- getCtLoc ScOrigin
719        ; ev_binds <- simplifyTop (unitBag (WcEvVar (WantedEvVar sc_dict loc)))
720        ; let ev_wrap = WpLet (EvBinds ev_binds)
721              sc_bind = mkVarBind sc_dict (noLoc $ (wrapId ev_wrap sc_dict))
722        ; return (unitBag sc_bind, sc_dict, DFunConstArg (Var sc_dict)) }
723            -- It's very important to solve the superclass constraint *in isolation*
724            -- so that it isn't generated by superclass selection from something else
725            -- We then generate the (also rather degenerate) top-level binding:
726            --      sc_dict = let sc_dict = <blah> in sc_dict
727            -- where <blah> is generated by solving the implication constraint
728   where
729     find _ [] = Nothing
730     find i (ev:evs) | pred `tcEqPred` evVarPred ev = Just (ev, i)
731                     | otherwise                    = find (i+1) evs
732
733 ------------------------------
734 tcSpecInstPrags :: DFunId -> InstBindings Name
735                 -> TcM ([Located TcSpecPrag], PragFun)
736 tcSpecInstPrags _ (NewTypeDerived {})
737   = return ([], \_ -> [])
738 tcSpecInstPrags dfun_id (VanillaInst binds uprags _)
739   = do { spec_inst_prags <- mapM (wrapLocM (tcSpecInst dfun_id)) $
740                             filter isSpecInstLSig uprags
741              -- The filter removes the pragmas for methods
742        ; return (spec_inst_prags, mkPragFun uprags binds) }
743 \end{code}
744
745 Note [Silent Superclass Arguments]
746 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
747 Consider the following (extreme) situation:
748         class C a => D a where ...
749         instance D [a] => D [a] where ...
750 Although this looks wrong (assume D [a] to prove D [a]), it is only a
751 more extreme case of what happens with recursive dictionaries.
752
753 To implement the dfun we must generate code for the superclass C [a],
754 which we can get by superclass selection from the supplied argument!
755 So we’d generate:
756        dfun :: forall a. D [a] -> D [a]
757        dfun = \d::D [a] -> MkD (scsel d) ..
758
759 However this means that if we later encounter a situation where
760 we have a [Wanted] dw::D [a] we could solve it thus:
761      dw := dfun dw
762 Although recursive, this binding would pass the TcSMonadisGoodRecEv
763 check because it appears as guarded.  But in reality, it will make a
764 bottom superclass. The trouble is that isGoodRecEv can't "see" the
765 superclass-selection inside dfun.
766
767 Our solution to this problem is to change the way ‘dfuns’ are created
768 for instances, so that we pass as first arguments to the dfun some
769 ``silent superclass arguments’’, which are the immediate superclasses
770 of the dictionary we are trying to construct. In our example:
771        dfun :: forall a. (C [a], D [a] -> D [a]
772        dfun = \(dc::C [a]) (dd::D [a]) -> DOrd dc ...
773
774 This gives us:
775
776      -----------------------------------------------------------
777      DFun Superclass Invariant
778      ~~~~~~~~~~~~~~~~~~~~~~~~
779      In the body of a DFun, every superclass argument to the
780      returned dictionary is
781        either   * one of the arguments of the DFun,
782        or       * constant, bound at top level
783      -----------------------------------------------------------
784
785 This means that no superclass is hidden inside a dfun application, so
786 the counting argument in isGoodRecEv (more dfun calls than superclass
787 selections) works correctly.
788
789 The extra arguments required to satisfy the DFun Superclass Invariant
790 always come first, and are called the "silent" arguments.  DFun types
791 are built (only) by MkId.mkDictFunId, so that is where we decide
792 what silent arguments are to be added.
793
794 This net effect is that it is safe to treat a dfun application as
795 wrapping a dictionary constructor around its arguments (in particular,
796 a dfun never picks superclasses from the arguments under the dictionary
797 constructor).
798
799 In our example, if we had  [Wanted] dw :: D [a] we would get via the instance:
800     dw := dfun d1 d2
801     [Wanted] (d1 :: C [a])
802     [Wanted] (d2 :: D [a])
803     [Derived] (d :: D [a])
804     [Derived] (scd :: C [a])   scd  := scsel d
805     [Derived] (scd2 :: C [a])  scd2 := scsel d2
806
807 And now, though we *can* solve: 
808      d2 := dw
809 we will get an isGoodRecEv failure when we try to solve:
810     d1 := scsel d 
811  or
812     d1 := scsel d2 
813
814 Test case SCLoop tests this fix. 
815          
816 Note [SPECIALISE instance pragmas]
817 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
818 Consider
819
820    instance (Ix a, Ix b) => Ix (a,b) where
821      {-# SPECIALISE instance Ix (Int,Int) #-}
822      range (x,y) = ...
823
824 We do *not* want to make a specialised version of the dictionary
825 function.  Rather, we want specialised versions of each method.
826 Thus we should generate something like this:
827
828   $dfIx :: (Ix a, Ix x) => Ix (a,b)
829   {- DFUN [$crange, ...] -}
830   $dfIx da db = Ix ($crange da db) (...other methods...)
831
832   $dfIxPair :: (Ix a, Ix x) => Ix (a,b)
833   {- DFUN [$crangePair, ...] -}
834   $dfIxPair = Ix ($crangePair da db) (...other methods...)
835
836   $crange :: (Ix a, Ix b) -> ((a,b),(a,b)) -> [(a,b)]
837   {-# SPECIALISE $crange :: ((Int,Int),(Int,Int)) -> [(Int,Int)] #-}
838   $crange da db = <blah>
839
840   {-# RULE  range ($dfIx da db) = $crange da db #-}
841
842 Note that  
843
844   * The RULE is unaffected by the specialisation.  We don't want to
845     specialise $dfIx, because then it would need a specialised RULE
846     which is a pain.  The single RULE works fine at all specialisations.
847     See Note [How instance declarations are translated] above
848
849   * Instead, we want to specialise the *method*, $crange
850
851 In practice, rather than faking up a SPECIALISE pragama for each
852 method (which is painful, since we'd have to figure out its
853 specialised type), we call tcSpecPrag *as if* were going to specialise
854 $dfIx -- you can see that in the call to tcSpecInst.  That generates a
855 SpecPrag which, as it turns out, can be used unchanged for each method.
856 The "it turns out" bit is delicate, but it works fine!
857
858 \begin{code}
859 tcSpecInst :: Id -> Sig Name -> TcM TcSpecPrag
860 tcSpecInst dfun_id prag@(SpecInstSig hs_ty) 
861   = addErrCtxt (spec_ctxt prag) $
862     do  { let name = idName dfun_id
863         ; (tyvars, theta, clas, tys) <- tcHsInstHead hs_ty
864         ; let (_, spec_dfun_ty) = mkDictFunTy tyvars theta clas tys
865
866         ; co_fn <- tcSubType (SpecPragOrigin name) (SigSkol SpecInstCtxt)
867                              (idType dfun_id) spec_dfun_ty
868         ; return (SpecPrag dfun_id co_fn defaultInlinePragma) }
869   where
870     spec_ctxt prag = hang (ptext (sLit "In the SPECIALISE pragma")) 2 (ppr prag)
871
872 tcSpecInst _  _ = panic "tcSpecInst"
873 \end{code}
874
875 %************************************************************************
876 %*                                                                      *
877       Type-checking an instance method
878 %*                                                                      *
879 %************************************************************************
880
881 tcInstanceMethod
882 - Make the method bindings, as a [(NonRec, HsBinds)], one per method
883 - Remembering to use fresh Name (the instance method Name) as the binder
884 - Bring the instance method Ids into scope, for the benefit of tcInstSig
885 - Use sig_fn mapping instance method Name -> instance tyvars
886 - Ditto prag_fn
887 - Use tcValBinds to do the checking
888
889 \begin{code}
890 tcInstanceMethods :: DFunId -> Class -> [TcTyVar]
891                   -> [EvVar]
892                   -> [TcType]
893                   -> ([Located TcSpecPrag], PragFun)
894                   -> [(Id, DefMeth)]
895                   -> InstBindings Name 
896                   -> TcM ([Id], [LHsBind Id])
897         -- The returned inst_meth_ids all have types starting
898         --      forall tvs. theta => ...
899 tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys 
900                   (spec_inst_prags, prag_fn)
901                   op_items (VanillaInst binds _ standalone_deriv)
902   = mapAndUnzipM tc_item op_items
903   where
904     ----------------------
905     tc_item :: (Id, DefMeth) -> TcM (Id, LHsBind Id)
906     tc_item (sel_id, dm_info)
907       = case findMethodBind (idName sel_id) binds of
908             Just user_bind -> tc_body sel_id standalone_deriv user_bind
909             Nothing        -> tc_default sel_id dm_info
910
911     ----------------------
912     tc_body :: Id -> Bool -> LHsBind Name -> TcM (TcId, LHsBind Id)
913     tc_body sel_id generated_code rn_bind 
914       = add_meth_ctxt sel_id generated_code rn_bind $
915         do { (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars 
916                                                    inst_tys sel_id
917            ; let prags = prag_fn (idName sel_id)
918            ; meth_id1 <- addInlinePrags meth_id prags
919            ; spec_prags <- tcSpecPrags meth_id1 prags
920            ; bind <- tcInstanceMethodBody InstSkol
921                           tyvars dfun_ev_vars
922                           meth_id1 local_meth_id meth_sig_fn 
923                           (mk_meth_spec_prags meth_id1 spec_prags)
924                           rn_bind 
925            ; return (meth_id1, bind) }
926
927     ----------------------
928     tc_default :: Id -> DefMeth -> TcM (TcId, LHsBind Id)
929     tc_default sel_id GenDefMeth    -- Derivable type classes stuff
930       = do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id
931            ; tc_body sel_id False {- Not generated code? -} meth_bind }
932           
933     tc_default sel_id NoDefMeth     -- No default method at all
934       = do { warnMissingMethod sel_id
935            ; (meth_id, _) <- mkMethIds clas tyvars dfun_ev_vars 
936                                          inst_tys sel_id
937            ; return (meth_id, mkVarBind meth_id $ 
938                               mkLHsWrap lam_wrapper error_rhs) }
939       where
940         error_rhs    = L loc $ HsApp error_fun error_msg
941         error_fun    = L loc $ wrapId (WpTyApp meth_tau) nO_METHOD_BINDING_ERROR_ID
942         error_msg    = L loc (HsLit (HsStringPrim (mkFastString error_string)))
943         meth_tau     = funResultTy (applyTys (idType sel_id) inst_tys)
944         error_string = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
945         lam_wrapper  = mkWpTyLams tyvars <.> mkWpLams dfun_ev_vars
946
947     tc_default sel_id (DefMeth dm_name) -- A polymorphic default method
948       = do {   -- Build the typechecked version directly, 
949                  -- without calling typecheck_method; 
950                  -- see Note [Default methods in instances]
951                  -- Generate   /\as.\ds. let self = df as ds
952                  --                      in $dm inst_tys self
953                  -- The 'let' is necessary only because HsSyn doesn't allow
954                  -- you to apply a function to a dictionary *expression*.
955
956            ; self_dict <- newEvVar (ClassP clas inst_tys)
957            ; let self_ev_bind = EvBind self_dict $
958                                 EvDFunApp dfun_id (mkTyVarTys tyvars) dfun_ev_vars
959
960            ; (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars 
961                                                    inst_tys sel_id
962            ; dm_id <- tcLookupId dm_name
963            ; let dm_inline_prag = idInlinePragma dm_id
964                  rhs = HsWrap (mkWpEvVarApps [self_dict] <.> mkWpTyApps inst_tys) $
965                          HsVar dm_id 
966
967                  meth_bind = L loc $ VarBind { var_id = local_meth_id
968                                              , var_rhs = L loc rhs 
969                                              , var_inline = False }
970                  meth_id1 = meth_id `setInlinePragma` dm_inline_prag
971                             -- Copy the inline pragma (if any) from the default
972                             -- method to this version. Note [INLINE and default methods]
973                             
974                  bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars =  dfun_ev_vars
975                                  , abs_exports = [( tyvars, meth_id1, local_meth_id
976                                                   , mk_meth_spec_prags meth_id1 [])]
977                                  , abs_ev_binds = EvBinds (unitBag self_ev_bind)
978                                  , abs_binds    = unitBag meth_bind }
979              -- Default methods in an instance declaration can't have their own 
980              -- INLINE or SPECIALISE pragmas. It'd be possible to allow them, but
981              -- currently they are rejected with 
982              --           "INLINE pragma lacks an accompanying binding"
983
984            ; return (meth_id1, L loc bind) } 
985
986     ----------------------
987     mk_meth_spec_prags :: Id -> [LTcSpecPrag] -> TcSpecPrags
988         -- Adapt the SPECIALISE pragmas to work for this method Id
989         -- There are two sources: 
990         --   * spec_inst_prags: {-# SPECIALISE instance :: <blah> #-}
991         --     These ones have the dfun inside, but [perhaps surprisingly] 
992         --     the correct wrapper
993         --   * spec_prags_for_me: {-# SPECIALISE op :: <blah> #-}
994     mk_meth_spec_prags meth_id spec_prags_for_me
995       = SpecPrags (spec_prags_for_me ++ 
996                    [ L loc (SpecPrag meth_id wrap inl)
997                    | L loc (SpecPrag _ wrap inl) <- spec_inst_prags])
998    
999     loc = getSrcSpan dfun_id
1000     meth_sig_fn _ = Just ([],loc)       -- The 'Just' says "yes, there's a type sig"
1001         -- But there are no scoped type variables from local_method_id
1002         -- Only the ones from the instance decl itself, which are already
1003         -- in scope.  Example:
1004         --      class C a where { op :: forall b. Eq b => ... }
1005         --      instance C [c] where { op = <rhs> }
1006         -- In <rhs>, 'c' is scope but 'b' is not!
1007
1008         -- For instance decls that come from standalone deriving clauses
1009         -- we want to print out the full source code if there's an error
1010         -- because otherwise the user won't see the code at all
1011     add_meth_ctxt sel_id generated_code rn_bind thing 
1012       | generated_code = addLandmarkErrCtxt (derivBindCtxt sel_id clas inst_tys rn_bind) thing
1013       | otherwise      = thing
1014
1015
1016 tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys 
1017                   _ op_items (NewTypeDerived coi _)
1018
1019 -- Running example:
1020 --   class Show b => Foo a b where
1021 --     op :: a -> b -> b
1022 --   newtype N a = MkN (Tree [a]) 
1023 --   deriving instance (Show p, Foo Int p) => Foo Int (N p)
1024 --               -- NB: standalone deriving clause means
1025 --               --     that the contex is user-specified
1026 -- Hence op :: forall a b. Foo a b => a -> b -> b
1027 --
1028 -- We're going to make an instance like
1029 --   instance (Show p, Foo Int p) => Foo Int (N p)
1030 --      op = $copT
1031 --
1032 --   $copT :: forall p. (Show p, Foo Int p) => Int -> N p -> N p
1033 --   $copT p (d1:Show p) (d2:Foo Int p) 
1034 --     = op Int (Tree [p]) rep_d |> op_co
1035 --     where 
1036 --       rep_d :: Foo Int (Tree [p]) = ...d1...d2...
1037 --       op_co :: (Int -> Tree [p] -> Tree [p]) ~ (Int -> T p -> T p)
1038 -- We get op_co by substituting [Int/a] and [co/b] in type for op
1039 -- where co : [p] ~ T p
1040 --
1041 -- Notice that the dictionary bindings "..d1..d2.." must be generated
1042 -- by the constraint solver, since the <context> may be
1043 -- user-specified.
1044
1045   = do { rep_d_stuff <- checkConstraints InstSkol tyvars dfun_ev_vars $
1046                         emitWanted ScOrigin rep_pred
1047                          
1048        ; mapAndUnzipM (tc_item rep_d_stuff) op_items }
1049   where
1050      loc = getSrcSpan dfun_id
1051
1052      inst_tvs = fst (tcSplitForAllTys (idType dfun_id))
1053      Just (init_inst_tys, _) = snocView inst_tys
1054      rep_ty   = fst (coercionKind co)  -- [p]
1055      rep_pred = mkClassPred clas (init_inst_tys ++ [rep_ty])
1056
1057      -- co : [p] ~ T p
1058      co = substTyWith inst_tvs (mkTyVarTys tyvars) $
1059           case coi of { IdCo ty -> ty ;
1060                         ACo co  -> mkSymCoercion co }
1061
1062      ----------------
1063      tc_item :: (TcEvBinds, EvVar) -> (Id, DefMeth) -> TcM (TcId, LHsBind TcId)
1064      tc_item (rep_ev_binds, rep_d) (sel_id, _)
1065        = do { (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars 
1066                                                     inst_tys sel_id
1067
1068             ; let meth_rhs  = wrapId (mk_op_wrapper sel_id rep_d) sel_id
1069                   meth_bind = VarBind { var_id = local_meth_id
1070                                       , var_rhs = L loc meth_rhs
1071                                       , var_inline = False }
1072
1073                   bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars
1074                                    , abs_exports = [(tyvars, meth_id, 
1075                                                      local_meth_id, noSpecPrags)]
1076                                    , abs_ev_binds = rep_ev_binds
1077                                    , abs_binds = unitBag $ L loc meth_bind }
1078
1079             ; return (meth_id, L loc bind) }
1080
1081      ----------------
1082      mk_op_wrapper :: Id -> EvVar -> HsWrapper
1083      mk_op_wrapper sel_id rep_d 
1084        = WpCast (substTyWith sel_tvs (init_inst_tys ++ [co]) local_meth_ty)
1085          <.> WpEvApp (EvId rep_d)
1086          <.> mkWpTyApps (init_inst_tys ++ [rep_ty]) 
1087        where
1088          (sel_tvs, sel_rho) = tcSplitForAllTys (idType sel_id)
1089          (_, local_meth_ty) = tcSplitPredFunTy_maybe sel_rho
1090                               `orElse` pprPanic "tcInstanceMethods" (ppr sel_id)
1091
1092 ----------------------
1093 mkMethIds :: Class -> [TcTyVar] -> [EvVar] -> [TcType] -> Id -> TcM (TcId, TcId)
1094 mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id
1095   = do  { uniq <- newUnique
1096         ; let meth_name = mkDerivedInternalName mkClassOpAuxOcc uniq sel_name
1097         ; local_meth_name <- newLocalName sel_name
1098                   -- Base the local_meth_name on the selector name, becuase
1099                   -- type errors from tcInstanceMethodBody come from here
1100
1101         ; let meth_id       = mkLocalId meth_name meth_ty
1102               local_meth_id = mkLocalId local_meth_name local_meth_ty
1103         ; return (meth_id, local_meth_id) }
1104   where
1105     local_meth_ty = instantiateMethod clas sel_id inst_tys
1106     meth_ty = mkForAllTys tyvars $ mkPiTypes dfun_ev_vars local_meth_ty
1107     sel_name = idName sel_id
1108
1109 ----------------------
1110 wrapId :: HsWrapper -> id -> HsExpr id
1111 wrapId wrapper id = mkHsWrap wrapper (HsVar id)
1112
1113 derivBindCtxt :: Id -> Class -> [Type ] -> LHsBind Name -> SDoc
1114 derivBindCtxt sel_id clas tys _bind
1115    = vcat [ ptext (sLit "When typechecking the code for ") <+> quotes (ppr sel_id)
1116           , nest 2 (ptext (sLit "in a standalone derived instance for")
1117                     <+> quotes (pprClassPred clas tys) <> colon)
1118           , nest 2 $ ptext (sLit "To see the code I am typechecking, use -ddump-deriv") ]
1119
1120 -- Too voluminous
1121 --        , nest 2 $ pprSetDepth AllTheWay $ ppr bind ]
1122
1123 warnMissingMethod :: Id -> TcM ()
1124 warnMissingMethod sel_id
1125   = do { warn <- doptM Opt_WarnMissingMethods           
1126        ; warnTc (warn  -- Warn only if -fwarn-missing-methods
1127                  && not (startsWithUnderscore (getOccName sel_id)))
1128                                         -- Don't warn about _foo methods
1129                 (ptext (sLit "No explicit method nor default method for")
1130                  <+> quotes (ppr sel_id)) }
1131 \end{code}
1132
1133 Note [Export helper functions]
1134 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1135 We arrange to export the "helper functions" of an instance declaration,
1136 so that they are not subject to preInlineUnconditionally, even if their
1137 RHS is trivial.  Reason: they are mentioned in the DFunUnfolding of
1138 the dict fun as Ids, not as CoreExprs, so we can't substitute a 
1139 non-variable for them.
1140
1141 We could change this by making DFunUnfoldings have CoreExprs, but it
1142 seems a bit simpler this way.
1143
1144 Note [Default methods in instances]
1145 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1146 Consider this
1147
1148    class Baz v x where
1149       foo :: x -> x
1150       foo y = <blah>
1151
1152    instance Baz Int Int
1153
1154 From the class decl we get
1155
1156    $dmfoo :: forall v x. Baz v x => x -> x
1157    $dmfoo y = <blah>
1158
1159 Notice that the type is ambiguous.  That's fine, though. The instance
1160 decl generates
1161
1162    $dBazIntInt = MkBaz fooIntInt
1163    fooIntInt = $dmfoo Int Int $dBazIntInt
1164
1165 BUT this does mean we must generate the dictionary translation of
1166 fooIntInt directly, rather than generating source-code and
1167 type-checking it.  That was the bug in Trac #1061. In any case it's
1168 less work to generate the translated version!
1169
1170 Note [INLINE and default methods]
1171 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1172 Default methods need special case.  They are supposed to behave rather like
1173 macros.  For exmample
1174
1175   class Foo a where
1176     op1, op2 :: Bool -> a -> a
1177
1178     {-# INLINE op1 #-}
1179     op1 b x = op2 (not b) x
1180
1181   instance Foo Int where
1182     -- op1 via default method
1183     op2 b x = <blah>
1184    
1185 The instance declaration should behave
1186
1187    just as if 'op1' had been defined with the
1188    code, and INLINE pragma, from its original
1189    definition. 
1190
1191 That is, just as if you'd written
1192
1193   instance Foo Int where
1194     op2 b x = <blah>
1195
1196     {-# INLINE op1 #-}
1197     op1 b x = op2 (not b) x
1198
1199 So for the above example we generate:
1200
1201
1202   {-# INLINE $dmop1 #-}
1203   -- $dmop1 has an InlineCompulsory unfolding
1204   $dmop1 d b x = op2 d (not b) x
1205
1206   $fFooInt = MkD $cop1 $cop2
1207
1208   {-# INLINE $cop1 #-}
1209   $cop1 = $dmop1 $fFooInt
1210
1211   $cop2 = <blah>
1212
1213 Note carefullly:
1214
1215 * We *copy* any INLINE pragma from the default method $dmop1 to the
1216   instance $cop1.  Otherwise we'll just inline the former in the
1217   latter and stop, which isn't what the user expected
1218
1219 * Regardless of its pragma, we give the default method an 
1220   unfolding with an InlineCompulsory source. That means
1221   that it'll be inlined at every use site, notably in
1222   each instance declaration, such as $cop1.  This inlining
1223   must happen even though 
1224     a) $dmop1 is not saturated in $cop1
1225     b) $cop1 itself has an INLINE pragma
1226
1227   It's vital that $dmop1 *is* inlined in this way, to allow the mutual
1228   recursion between $fooInt and $cop1 to be broken
1229
1230 * To communicate the need for an InlineCompulsory to the desugarer
1231   (which makes the Unfoldings), we use the IsDefaultMethod constructor
1232   in TcSpecPrags.
1233
1234
1235 %************************************************************************
1236 %*                                                                      *
1237 \subsection{Error messages}
1238 %*                                                                      *
1239 %************************************************************************
1240
1241 \begin{code}
1242 instDeclCtxt1 :: LHsType Name -> SDoc
1243 instDeclCtxt1 hs_inst_ty
1244   = inst_decl_ctxt (case unLoc hs_inst_ty of
1245                         HsForAllTy _ _ _ (L _ (HsPredTy pred)) -> ppr pred
1246                         HsPredTy pred                    -> ppr pred
1247                         _                                -> ppr hs_inst_ty)     -- Don't expect this
1248 instDeclCtxt2 :: Type -> SDoc
1249 instDeclCtxt2 dfun_ty
1250   = inst_decl_ctxt (ppr (mkClassPred cls tys))
1251   where
1252     (_,_,cls,tys) = tcSplitDFunTy dfun_ty
1253
1254 inst_decl_ctxt :: SDoc -> SDoc
1255 inst_decl_ctxt doc = ptext (sLit "In the instance declaration for") <+> quotes doc
1256
1257 atInstCtxt :: Name -> SDoc
1258 atInstCtxt name = ptext (sLit "In the associated type instance for") <+>
1259                   quotes (ppr name)
1260
1261 mustBeVarArgErr :: Type -> SDoc
1262 mustBeVarArgErr ty =
1263   sep [ ptext (sLit "Arguments that do not correspond to a class parameter") <+>
1264         ptext (sLit "must be variables")
1265       , ptext (sLit "Instead of a variable, found") <+> ppr ty
1266       ]
1267
1268 wrongATArgErr :: Type -> Type -> SDoc
1269 wrongATArgErr ty instTy =
1270   sep [ ptext (sLit "Type indexes must match class instance head")
1271       , ptext (sLit "Found") <+> quotes (ppr ty)
1272         <+> ptext (sLit "but expected") <+> quotes (ppr instTy)
1273       ]
1274 \end{code}