More updates to Safe Haskell to implement new design (done!).
[ghc.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 #include "HsVersions.h"
12
13 import HsSyn
14 import TcBinds
15 import TcTyClsDecls
16 import TcClassDcl
17 import TcPat      ( addInlinePrags )
18 import TcRnMonad
19 import TcMType
20 import TcType
21 import BuildTyCl
22 import Inst
23 import InstEnv
24 import FamInst
25 import FamInstEnv
26 import TcDeriv
27 import TcEnv
28 import TcHsType
29 import TcUnify
30 import MkCore     ( nO_METHOD_BINDING_ERROR_ID )
31 import Type
32 import Coercion hiding (substTy)
33 import TyCon
34 import DataCon
35 import Class
36 import Var
37 import VarEnv
38 import VarSet     ( mkVarSet, varSetElems )
39 import Pair
40 import CoreUtils  ( mkPiTypes )
41 import CoreUnfold ( mkDFunUnfolding )
42 import CoreSyn    ( Expr(Var), CoreExpr, varToCoreExpr )
43 import PrelNames  ( typeableClassNames )
44
45 import Bag
46 import BasicTypes
47 import DynFlags
48 import FastString
49 import HscTypes
50 import Id
51 import MkId
52 import Name
53 import NameSet
54 import Outputable
55 import SrcLoc
56 import Util
57
58 import Control.Monad
59 import Data.Maybe
60 import Maybes     ( orElse )
61 \end{code}
62
63 Typechecking instance declarations is done in two passes. The first
64 pass, made by @tcInstDecls1@, collects information to be used in the
65 second pass.
66
67 This pre-processed info includes the as-yet-unprocessed bindings
68 inside the instance declaration.  These are type-checked in the second
69 pass, when the class-instance envs and GVE contain all the info from
70 all the instance and value decls.  Indeed that's the reason we need
71 two passes over the instance decls.
72
73
74 Note [How instance declarations are translated]
75 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
76 Here is how we translation instance declarations into Core
77
78 Running example:
79         class C a where
80            op1, op2 :: Ix b => a -> b -> b
81            op2 = <dm-rhs>
82
83         instance C a => C [a]
84            {-# INLINE [2] op1 #-}
85            op1 = <rhs>
86 ===>
87         -- Method selectors
88         op1,op2 :: forall a. C a => forall b. Ix b => a -> b -> b
89         op1 = ...
90         op2 = ...
91
92         -- Default methods get the 'self' dictionary as argument
93         -- so they can call other methods at the same type
94         -- Default methods get the same type as their method selector
95         $dmop2 :: forall a. C a => forall b. Ix b => a -> b -> b
96         $dmop2 = /\a. \(d:C a). /\b. \(d2: Ix b). <dm-rhs>
97                -- NB: type variables 'a' and 'b' are *both* in scope in <dm-rhs>
98                -- Note [Tricky type variable scoping]
99
100         -- A top-level definition for each instance method
101         -- Here op1_i, op2_i are the "instance method Ids"
102         -- The INLINE pragma comes from the user pragma
103         {-# INLINE [2] op1_i #-}  -- From the instance decl bindings
104         op1_i, op2_i :: forall a. C a => forall b. Ix b => [a] -> b -> b
105         op1_i = /\a. \(d:C a).
106                let this :: C [a]
107                    this = df_i a d
108                      -- Note [Subtle interaction of recursion and overlap]
109
110                    local_op1 :: forall b. Ix b => [a] -> b -> b
111                    local_op1 = <rhs>
112                      -- Source code; run the type checker on this
113                      -- NB: Type variable 'a' (but not 'b') is in scope in <rhs>
114                      -- Note [Tricky type variable scoping]
115
116                in local_op1 a d
117
118         op2_i = /\a \d:C a. $dmop2 [a] (df_i a d)
119
120         -- The dictionary function itself
121         {-# NOINLINE CONLIKE df_i #-}   -- Never inline dictionary functions
122         df_i :: forall a. C a -> C [a]
123         df_i = /\a. \d:C a. MkC (op1_i a d) (op2_i a d)
124                 -- But see Note [Default methods in instances]
125                 -- We can't apply the type checker to the default-method call
126
127         -- Use a RULE to short-circuit applications of the class ops
128         {-# RULE "op1@C[a]" forall a, d:C a.
129                             op1 [a] (df_i d) = op1_i a d #-}
130
131 Note [Instances and loop breakers]
132 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
133 * Note that df_i may be mutually recursive with both op1_i and op2_i.
134   It's crucial that df_i is not chosen as the loop breaker, even
135   though op1_i has a (user-specified) INLINE pragma.
136
137 * Instead the idea is to inline df_i into op1_i, which may then select
138   methods from the MkC record, and thereby break the recursion with
139   df_i, leaving a *self*-recurisve op1_i.  (If op1_i doesn't call op at
140   the same type, it won't mention df_i, so there won't be recursion in
141   the first place.)
142
143 * If op1_i is marked INLINE by the user there's a danger that we won't
144   inline df_i in it, and that in turn means that (since it'll be a
145   loop-breaker because df_i isn't), op1_i will ironically never be
146   inlined.  But this is OK: the recursion breaking happens by way of
147   a RULE (the magic ClassOp rule above), and RULES work inside InlineRule
148   unfoldings. See Note [RULEs enabled in SimplGently] in SimplUtils
149
150 Note [ClassOp/DFun selection]
151 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
152 One thing we see a lot is stuff like
153     op2 (df d1 d2)
154 where 'op2' is a ClassOp and 'df' is DFun.  Now, we could inline *both*
155 'op2' and 'df' to get
156      case (MkD ($cop1 d1 d2) ($cop2 d1 d2) ... of
157        MkD _ op2 _ _ _ -> op2
158 And that will reduce to ($cop2 d1 d2) which is what we wanted.
159
160 But it's tricky to make this work in practice, because it requires us to
161 inline both 'op2' and 'df'.  But neither is keen to inline without having
162 seen the other's result; and it's very easy to get code bloat (from the
163 big intermediate) if you inline a bit too much.
164
165 Instead we use a cunning trick.
166  * We arrange that 'df' and 'op2' NEVER inline.
167
168  * We arrange that 'df' is ALWAYS defined in the sylised form
169       df d1 d2 = MkD ($cop1 d1 d2) ($cop2 d1 d2) ...
170
171  * We give 'df' a magical unfolding (DFunUnfolding [$cop1, $cop2, ..])
172    that lists its methods.
173
174  * We make CoreUnfold.exprIsConApp_maybe spot a DFunUnfolding and return
175    a suitable constructor application -- inlining df "on the fly" as it
176    were.
177
178  * We give the ClassOp 'op2' a BuiltinRule that extracts the right piece
179    iff its argument satisfies exprIsConApp_maybe.  This is done in
180    MkId mkDictSelId
181
182  * We make 'df' CONLIKE, so that shared uses stil match; eg
183       let d = df d1 d2
184       in ...(op2 d)...(op1 d)...
185
186 Note [Single-method classes]
187 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
188 If the class has just one method (or, more accurately, just one element
189 of {superclasses + methods}), then we use a different strategy.
190
191    class C a where op :: a -> a
192    instance C a => C [a] where op = <blah>
193
194 We translate the class decl into a newtype, which just gives a
195 top-level axiom. The "constructor" MkC expands to a cast, as does the
196 class-op selector.
197
198    axiom Co:C a :: C a ~ (a->a)
199
200    op :: forall a. C a -> (a -> a)
201    op a d = d |> (Co:C a)
202
203    MkC :: forall a. (a->a) -> C a
204    MkC = /\a.\op. op |> (sym Co:C a)
205
206 The clever RULE stuff doesn't work now, because ($df a d) isn't
207 a constructor application, so exprIsConApp_maybe won't return
208 Just <blah>.
209
210 Instead, we simply rely on the fact that casts are cheap:
211
212    $df :: forall a. C a => C [a]
213    {-# INLINE df #-}  -- NB: INLINE this
214    $df = /\a. \d. MkC [a] ($cop_list a d)
215        = $cop_list |> forall a. C a -> (sym (Co:C [a]))
216
217    $cop_list :: forall a. C a => [a] -> [a]
218    $cop_list = <blah>
219
220 So if we see
221    (op ($df a d))
222 we'll inline 'op' and '$df', since both are simply casts, and
223 good things happen.
224
225 Why do we use this different strategy?  Because otherwise we
226 end up with non-inlined dictionaries that look like
227     $df = $cop |> blah
228 which adds an extra indirection to every use, which seems stupid.  See
229 Trac #4138 for an example (although the regression reported there
230 wasn't due to the indirction).
231
232 There is an awkward wrinkle though: we want to be very
233 careful when we have
234     instance C a => C [a] where
235       {-# INLINE op #-}
236       op = ...
237 then we'll get an INLINE pragma on $cop_list but it's important that
238 $cop_list only inlines when it's applied to *two* arguments (the
239 dictionary and the list argument).  So we nust not eta-expand $df
240 above.  We ensure that this doesn't happen by putting an INLINE
241 pragma on the dfun itself; after all, it ends up being just a cast.
242
243 There is one more dark corner to the INLINE story, even more deeply
244 buried.  Consider this (Trac #3772):
245
246     class DeepSeq a => C a where
247       gen :: Int -> a
248
249     instance C a => C [a] where
250       gen n = ...
251
252     class DeepSeq a where
253       deepSeq :: a -> b -> b
254
255     instance DeepSeq a => DeepSeq [a] where
256       {-# INLINE deepSeq #-}
257       deepSeq xs b = foldr deepSeq b xs
258
259 That gives rise to these defns:
260
261     $cdeepSeq :: DeepSeq a -> [a] -> b -> b
262     -- User INLINE( 3 args )!
263     $cdeepSeq a (d:DS a) b (x:[a]) (y:b) = ...
264
265     $fDeepSeq[] :: DeepSeq a -> DeepSeq [a]
266     -- DFun (with auto INLINE pragma)
267     $fDeepSeq[] a d = $cdeepSeq a d |> blah
268
269     $cp1 a d :: C a => DeepSep [a]
270     -- We don't want to eta-expand this, lest
271     -- $cdeepSeq gets inlined in it!
272     $cp1 a d = $fDeepSep[] a (scsel a d)
273
274     $fC[] :: C a => C [a]
275     -- Ordinary DFun
276     $fC[] a d = MkC ($cp1 a d) ($cgen a d)
277
278 Here $cp1 is the code that generates the superclass for C [a].  The
279 issue is this: we must not eta-expand $cp1 either, or else $fDeepSeq[]
280 and then $cdeepSeq will inline there, which is definitely wrong.  Like
281 on the dfun, we solve this by adding an INLINE pragma to $cp1.
282
283 Note [Subtle interaction of recursion and overlap]
284 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
285 Consider this
286   class C a where { op1,op2 :: a -> a }
287   instance C a => C [a] where
288     op1 x = op2 x ++ op2 x
289     op2 x = ...
290   instance C [Int] where
291     ...
292
293 When type-checking the C [a] instance, we need a C [a] dictionary (for
294 the call of op2).  If we look up in the instance environment, we find
295 an overlap.  And in *general* the right thing is to complain (see Note
296 [Overlapping instances] in InstEnv).  But in *this* case it's wrong to
297 complain, because we just want to delegate to the op2 of this same
298 instance.
299
300 Why is this justified?  Because we generate a (C [a]) constraint in
301 a context in which 'a' cannot be instantiated to anything that matches
302 other overlapping instances, or else we would not be excecuting this
303 version of op1 in the first place.
304
305 It might even be a bit disguised:
306
307   nullFail :: C [a] => [a] -> [a]
308   nullFail x = op2 x ++ op2 x
309
310   instance C a => C [a] where
311     op1 x = nullFail x
312
313 Precisely this is used in package 'regex-base', module Context.hs.
314 See the overlapping instances for RegexContext, and the fact that they
315 call 'nullFail' just like the example above.  The DoCon package also
316 does the same thing; it shows up in module Fraction.hs
317
318 Conclusion: when typechecking the methods in a C [a] instance, we want to
319 treat the 'a' as an *existential* type variable, in the sense described
320 by Note [Binding when looking up instances].  That is why isOverlappableTyVar
321 responds True to an InstSkol, which is the kind of skolem we use in
322 tcInstDecl2.
323
324
325 Note [Tricky type variable scoping]
326 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
327 In our example
328         class C a where
329            op1, op2 :: Ix b => a -> b -> b
330            op2 = <dm-rhs>
331
332         instance C a => C [a]
333            {-# INLINE [2] op1 #-}
334            op1 = <rhs>
335
336 note that 'a' and 'b' are *both* in scope in <dm-rhs>, but only 'a' is
337 in scope in <rhs>.  In particular, we must make sure that 'b' is in
338 scope when typechecking <dm-rhs>.  This is achieved by subFunTys,
339 which brings appropriate tyvars into scope. This happens for both
340 <dm-rhs> and for <rhs>, but that doesn't matter: the *renamer* will have
341 complained if 'b' is mentioned in <rhs>.
342
343
344
345 %************************************************************************
346 %*                                                                      *
347 \subsection{Extracting instance decls}
348 %*                                                                      *
349 %************************************************************************
350
351 Gather up the instance declarations from their various sources
352
353 \begin{code}
354 tcInstDecls1    -- Deal with both source-code and imported instance decls
355    :: [LTyClDecl Name]          -- For deriving stuff
356    -> [LInstDecl Name]          -- Source code instance decls
357    -> [LDerivDecl Name]         -- Source code stand-alone deriving decls
358    -> TcM (TcGblEnv,            -- The full inst env
359            [InstInfo Name],     -- Source-code instance decls to process;
360                                 -- contains all dfuns for this module
361            HsValBinds Name)     -- Supporting bindings for derived instances
362
363 tcInstDecls1 tycl_decls inst_decls deriv_decls 
364   = checkNoErrs $
365     do {        -- Stop if addInstInfos etc discovers any errors
366                 -- (they recover, so that we get more than one error each
367                 -- round)
368
369                 -- (1) Do class and family instance declarations
370        ; idx_tycons        <- mapAndRecoverM tcTopFamInstDecl $
371                               filter (isFamInstDecl . unLoc) tycl_decls
372        ; local_info_tycons <- mapAndRecoverM tcLocalInstDecl1  inst_decls
373
374        ; let { (local_info,
375                 at_tycons_s)   = unzip local_info_tycons
376              ; at_idx_tycons   = concat at_tycons_s ++ idx_tycons
377              ; implicit_things = concatMap implicitTyConThings at_idx_tycons
378              ; aux_binds       = mkRecSelBinds at_idx_tycons  }
379
380                 -- (2) Add the tycons of indexed types and their implicit
381                 --     tythings to the global environment
382        ; tcExtendGlobalEnvImplicit
383              (map ATyCon at_idx_tycons ++ implicit_things) $ do {
384
385
386                 -- Next, construct the instance environment so far, consisting
387                 -- of
388                 --   (a) local instance decls
389                 --   (b) local family instance decls
390        ; addInsts local_info         $
391          addFamInsts at_idx_tycons   $ do {
392
393                 -- (3) Compute instances from "deriving" clauses;
394                 -- This stuff computes a context for the derived instance
395                 -- decl, so it needs to know about all the instances possible
396                 -- NB: class instance declarations can contain derivings as
397                 --     part of associated data type declarations
398          failIfErrsM    -- If the addInsts stuff gave any errors, don't
399                         -- try the deriving stuff, because that may give
400                         -- more errors still
401
402        ; (gbl_env, deriv_inst_info, deriv_binds)
403               <- tcDeriving tycl_decls inst_decls deriv_decls
404
405        -- Check that if the module is compiled with -XSafe, there are no
406        -- hand written instances of Typeable as then unsafe casts could be
407        -- performed. Derived instances are OK.
408        ; dflags <- getDOpts
409        ; when (safeLanguageOn dflags) $
410              mapM_ (\x -> when (typInstCheck x)
411                                (addErrAt (getSrcSpan $ iSpec x) typInstErr))
412                    local_info
413        -- As above but for Safe Inference mode.
414        ; when (safeInferOn dflags) $
415              mapM_ (\x -> when (typInstCheck x) recordUnsafeInfer) local_info
416
417        ; return ( gbl_env
418                 , (bagToList deriv_inst_info) ++ local_info
419                 , aux_binds `plusHsValBinds` deriv_binds)
420     }}}
421   where
422     typInstCheck ty = is_cls (iSpec ty) `elem` typeableClassNames
423     typInstErr = ptext $ sLit $ "Can't create hand written instances of Typeable in Safe"
424                               ++ " Haskell! Can only derive them"
425
426 addInsts :: [InstInfo Name] -> TcM a -> TcM a
427 addInsts infos thing_inside
428   = tcExtendLocalInstEnv (map iSpec infos) thing_inside
429
430 addFamInsts :: [TyCon] -> TcM a -> TcM a
431 addFamInsts tycons thing_inside
432   = tcExtendLocalFamInstEnv (map mkLocalFamInst tycons) thing_inside
433 \end{code}
434
435 \begin{code}
436 tcLocalInstDecl1 :: LInstDecl Name
437                  -> TcM (InstInfo Name, [TyCon])
438         -- A source-file instance declaration
439         -- Type-check all the stuff before the "where"
440         --
441         -- We check for respectable instance type, and context
442 tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats))
443   = setSrcSpan loc                      $
444     addErrCtxt (instDeclCtxt1 poly_ty)  $
445
446     do  { is_boot <- tcIsHsBoot
447         ; checkTc (not is_boot || (isEmptyLHsBinds binds && null uprags))
448                   badBootDeclErr
449
450         ; (tyvars, theta, clas, inst_tys) <- tcHsInstHead poly_ty
451         ; checkValidInstance poly_ty tyvars theta clas inst_tys
452         ; let mini_env = mkVarEnv (classTyVars clas `zip` inst_tys)
453
454         -- Next, process any associated types.
455         ; traceTc "tcLocalInstDecl" (ppr poly_ty)
456         ; idx_tycons0 <- tcExtendTyVarEnv tyvars $
457                         mapAndRecoverM (tcAssocDecl clas mini_env) ats
458
459         -- Check for misssing associated types and build them
460         -- from their defaults (if available)
461         ; let defined_ats = mkNameSet $ map (tcdName . unLoc) ats
462               check_at_instance (fam_tc, defs)
463                  -- User supplied instances ==> everything is OK
464                 | tyConName fam_tc `elemNameSet` defined_ats = return (Nothing, [])
465                  -- No defaults ==> generate a warning
466                 | null defs                                  = return (Just (tyConName fam_tc), [])
467                  -- No user instance, have defaults ==> instatiate them
468                 | otherwise = do
469                     defs' <- forM defs $ \(ATD tvs pat_tys rhs) -> do
470                       let mini_env_subst = mkTvSubst (mkInScopeSet (mkVarSet tvs)) mini_env
471                           tvs' = varSetElems (tyVarsOfType rhs')
472                           pat_tys' = substTys mini_env_subst pat_tys
473                           rhs' = substTy mini_env_subst rhs
474                       rep_tc_name <- newFamInstTyConName (noLoc (tyConName fam_tc)) pat_tys'
475                       buildSynTyCon rep_tc_name tvs'
476                                     (SynonymTyCon rhs')
477                                     (mkArrowKinds (map tyVarKind tvs') (typeKind rhs'))
478                                     NoParentTyCon (Just (fam_tc, pat_tys'))
479                     return (Nothing, defs')
480         ; missing_at_stuff <- mapM check_at_instance (classATItems clas)
481         
482         ; let (omitted, idx_tycons1) = unzip missing_at_stuff
483         ; warn <- woptM Opt_WarnMissingMethods
484         ; mapM_ (warnTc warn . omittedATWarn) (catMaybes omitted)
485
486         -- Finally, construct the Core representation of the instance.
487         -- (This no longer includes the associated types.)
488         ; dfun_name <- newDFunName clas inst_tys (getLoc poly_ty)
489                 -- Dfun location is that of instance *header*
490
491         ; overlap_flag <- getOverlapFlag
492         ; let dfun      = mkDictFunId dfun_name tyvars theta clas inst_tys
493               ispec     = mkLocalInstance dfun overlap_flag
494               inst_info = InstInfo { iSpec  = ispec, iBinds = VanillaInst binds uprags False }
495
496         ; return (inst_info, idx_tycons0 ++ concat idx_tycons1) }
497 \end{code}
498
499
500 %************************************************************************
501 %*                                                                      *
502                Type checking family instances
503 %*                                                                      *
504 %************************************************************************
505
506 Family instances are somewhat of a hybrid.  They are processed together with
507 class instance heads, but can contain data constructors and hence they share a
508 lot of kinding and type checking code with ordinary algebraic data types (and
509 GADTs).
510
511 \begin{code}
512 tcTopFamInstDecl :: LTyClDecl Name -> TcM TyCon
513 tcTopFamInstDecl (L loc decl)
514   = setSrcSpan loc      $
515     tcAddDeclCtxt decl  $
516     tcFamInstDecl TopLevel decl
517
518 tcFamInstDecl :: TopLevelFlag -> TyClDecl Name -> TcM TyCon
519 tcFamInstDecl top_lvl decl
520   = do { -- type family instances require -XTypeFamilies
521          -- and can't (currently) be in an hs-boot file
522        ; let fam_tc_lname = tcdLName decl
523        ; type_families <- xoptM Opt_TypeFamilies
524        ; is_boot <- tcIsHsBoot   -- Are we compiling an hs-boot file?
525        ; checkTc type_families $ badFamInstDecl fam_tc_lname
526        ; checkTc (not is_boot) $ badBootFamInstDeclErr
527
528        -- Look up the family TyCon and check for validity including
529        -- check that toplevel type instances are not for associated types.
530        ; fam_tc <- tcLookupLocatedTyCon fam_tc_lname
531        ; checkTc (isFamilyTyCon fam_tc) (notFamily fam_tc)
532        ; when (isTopLevel top_lvl && isTyConAssoc fam_tc)
533               (addErr $ assocInClassErr fam_tc_lname)
534
535          -- Now check the type/data instance itself
536          -- This is where type and data decls are treated separately
537        ; tc <- tcFamInstDecl1 fam_tc decl
538        ; checkValidTyCon tc     -- Remember to check validity;
539                                 -- no recursion to worry about here
540
541        ; return tc }
542
543 tcFamInstDecl1 :: TyCon -> TyClDecl Name -> TcM TyCon
544
545   -- "type instance"
546 tcFamInstDecl1 fam_tc (decl@TySynonym {})
547   = kcFamTyPats decl $ \k_tvs k_typats resKind ->
548     do { -- kind check the right-hand side of the type equation
549        ; k_rhs <- kcCheckLHsType (tcdSynRhs decl) (EK resKind EkUnk)
550                   -- ToDo: the ExpKind could be better
551
552          -- (1) do the work of verifying the synonym
553        ; (t_tvs, t_typats, t_rhs) <- tcSynFamInstDecl fam_tc (decl { tcdTyVars = k_tvs, tcdTyPats = Just k_typats, tcdSynRhs = k_rhs })
554
555          -- (2) check the well-formedness of the instance
556        ; checkValidFamInst t_typats t_rhs
557
558          -- (3) construct representation tycon
559        ; rep_tc_name <- newFamInstTyConName (tcdLName decl) t_typats
560        ; buildSynTyCon rep_tc_name t_tvs
561                        (SynonymTyCon t_rhs)
562                        (typeKind t_rhs)
563                        NoParentTyCon (Just (fam_tc, t_typats))
564        }
565
566   -- "newtype instance" and "data instance"
567 tcFamInstDecl1 fam_tc (decl@TyData { tcdND = new_or_data
568                                    , tcdCons = cons})
569   = kcFamTyPats decl $ \k_tvs k_typats resKind ->
570     do { -- check that the family declaration is for the right kind
571          checkTc (isFamilyTyCon fam_tc) (notFamily fam_tc)
572        ; checkTc (isAlgTyCon fam_tc) (wrongKindOfFamily fam_tc)
573
574        ; -- (1) kind check the data declaration as usual
575        ; k_decl <- kcDataDecl decl k_tvs
576        ; let k_ctxt = tcdCtxt k_decl
577              k_cons = tcdCons k_decl
578
579          -- result kind must be '*' (otherwise, we have too few patterns)
580        ; resKind' <- zonkTcKindToKind resKind -- Remember: kcFamTyPats supplies unzonked kind!
581        ; checkTc (isLiftedTypeKind resKind') $ tooFewParmsErr (tyConArity fam_tc)
582
583          -- (2) type check indexed data type declaration
584        ; tcTyVarBndrs k_tvs $ \t_tvs -> do   -- turn kinded into proper tyvars
585
586          -- kind check the type indexes and the context
587        { t_typats     <- mapM tcHsKindedType k_typats
588        ; stupid_theta <- tcHsKindedContext k_ctxt
589
590          -- (3) Check that
591          --     (a) left-hand side contains no type family applications
592          --         (vanilla synonyms are fine, though, and we checked for
593          --         foralls earlier)
594        ; mapM_ checkTyFamFreeness t_typats
595
596        ; dataDeclChecks (tcdName decl) new_or_data stupid_theta k_cons
597
598          -- (4) construct representation tycon
599        ; rep_tc_name <- newFamInstTyConName (tcdLName decl) t_typats
600        ; let ex_ok = True       -- Existentials ok for type families!
601        ; fixM (\ rep_tycon -> do
602              { let orig_res_ty = mkTyConApp fam_tc t_typats
603              ; data_cons <- tcConDecls ex_ok rep_tycon
604                                        (t_tvs, orig_res_ty) k_cons
605              ; tc_rhs <-
606                  case new_or_data of
607                    DataType -> return (mkDataTyConRhs data_cons)
608                    NewType  -> ASSERT( not (null data_cons) )
609                                mkNewTyConRhs rep_tc_name rep_tycon (head data_cons)
610              ; buildAlgTyCon rep_tc_name t_tvs stupid_theta tc_rhs Recursive
611                              h98_syntax NoParentTyCon (Just (fam_tc, t_typats))
612                  -- We always assume that indexed types are recursive.  Why?
613                  -- (1) Due to their open nature, we can never be sure that a
614                  -- further instance might not introduce a new recursive
615                  -- dependency.  (2) They are always valid loop breakers as
616                  -- they involve a coercion.
617              })
618        }}
619        where
620          h98_syntax = case cons of      -- All constructors have same shape
621                         L _ (ConDecl { con_res = ResTyGADT _ }) : _ -> False
622                         _ -> True
623
624 tcFamInstDecl1 _ d = pprPanic "tcFamInstDecl1" (ppr d)
625
626
627 ----------------
628 tcAssocDecl :: Class           -- ^ Class of associated type
629             -> VarEnv Type     -- ^ Instantiation of class TyVars
630             -> LTyClDecl Name  -- ^ RHS
631             -> TcM TyCon
632 tcAssocDecl clas mini_env (L loc decl)
633   = setSrcSpan loc      $
634     tcAddDeclCtxt decl  $
635     do { at_tc <- tcFamInstDecl NotTopLevel decl
636        ; let Just (fam_tc, at_tys) = tyConFamInst_maybe at_tc
637   
638        -- Check that the associated type comes from this class
639        ; checkTc (Just clas == tyConAssoc_maybe fam_tc)
640                  (badATErr clas (tyConName at_tc))
641
642        -- See Note [Checking consistent instantiation]
643        ; zipWithM_ check_arg (tyConTyVars fam_tc) at_tys
644
645        ; return at_tc }
646   where
647     check_arg fam_tc_tv at_ty
648       | Just inst_ty <- lookupVarEnv mini_env fam_tc_tv
649       = checkTc (inst_ty `eqType` at_ty) 
650                 (wrongATArgErr at_ty inst_ty)
651       | otherwise
652       = return ()   -- Allow non-type-variable instantiation
653                     -- See Note [Associated type instances]
654 \end{code}
655
656
657 %************************************************************************
658 %*                                                                      *
659       Type-checking instance declarations, pass 2
660 %*                                                                      *
661 %************************************************************************
662
663 \begin{code}
664 tcInstDecls2 :: [LTyClDecl Name] -> [InstInfo Name]
665              -> TcM (LHsBinds Id)
666 -- (a) From each class declaration,
667 --      generate any default-method bindings
668 -- (b) From each instance decl
669 --      generate the dfun binding
670
671 tcInstDecls2 tycl_decls inst_decls
672   = do  { -- (a) Default methods from class decls
673           let class_decls = filter (isClassDecl . unLoc) tycl_decls
674         ; dm_binds_s <- mapM tcClassDecl2 class_decls
675         ; let dm_binds = unionManyBags dm_binds_s
676
677           -- (b) instance declarations
678         ; let dm_ids = collectHsBindsBinders dm_binds
679               -- Add the default method Ids (again)
680               -- See Note [Default methods and instances]
681         ; inst_binds_s <- tcExtendLetEnv TopLevel dm_ids $
682                           mapM tcInstDecl2 inst_decls
683
684           -- Done
685         ; return (dm_binds `unionBags` unionManyBags inst_binds_s) }
686 \end{code}
687
688 See Note [Default methods and instances]
689 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
690 The default method Ids are already in the type environment (see Note
691 [Default method Ids and Template Haskell] in TcTyClsDcls), BUT they
692 don't have their InlinePragmas yet.  Usually that would not matter,
693 because the simplifier propagates information from binding site to
694 use.  But, unusually, when compiling instance decls we *copy* the
695 INLINE pragma from the default method to the method for that
696 particular operation (see Note [INLINE and default methods] below).
697
698 So right here in tcInstDecls2 we must re-extend the type envt with
699 the default method Ids replete with their INLINE pragmas.  Urk.
700
701 \begin{code}
702
703 tcInstDecl2 :: InstInfo Name -> TcM (LHsBinds Id)
704             -- Returns a binding for the dfun
705 tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
706   = recoverM (return emptyLHsBinds)             $
707     setSrcSpan loc                              $
708     addErrCtxt (instDeclCtxt2 (idType dfun_id)) $
709     do {  -- Instantiate the instance decl with skolem constants
710        ; (inst_tyvars, dfun_theta, inst_head) <- tcSkolDFunType (idType dfun_id)
711                      -- We instantiate the dfun_id with superSkolems.
712                      -- See Note [Subtle interaction of recursion and overlap]
713                      -- and Note [Binding when looking up instances]
714        ; let (clas, inst_tys) = tcSplitDFunHead inst_head
715              (class_tyvars, sc_theta, sc_sels, op_items) = classBigSig clas
716              sc_theta' = substTheta (zipOpenTvSubst class_tyvars inst_tys) sc_theta
717        ; dfun_ev_vars <- newEvVars dfun_theta
718
719        ; (sc_args, sc_binds)
720              <- mapAndUnzipM (tcSuperClass inst_tyvars dfun_ev_vars)
721                               (sc_sels `zip` sc_theta')
722
723        -- Deal with 'SPECIALISE instance' pragmas
724        -- See Note [SPECIALISE instance pragmas]
725        ; spec_info@(spec_inst_prags,_) <- tcSpecInstPrags dfun_id ibinds
726
727         -- Typecheck the methods
728        ; (meth_ids, meth_binds)
729            <- tcExtendTyVarEnv inst_tyvars $
730                 -- The inst_tyvars scope over the 'where' part
731                 -- Those tyvars are inside the dfun_id's type, which is a bit
732                 -- bizarre, but OK so long as you realise it!
733               tcInstanceMethods dfun_id clas inst_tyvars dfun_ev_vars
734                                 inst_tys spec_info
735                                 op_items ibinds
736
737        -- Create the result bindings
738        ; self_dict <- newDict clas inst_tys
739        ; let class_tc      = classTyCon clas
740              [dict_constr] = tyConDataCons class_tc
741              dict_bind     = mkVarBind self_dict (L loc con_app_args)
742
743                      -- We don't produce a binding for the dict_constr; instead we
744                      -- rely on the simplifier to unfold this saturated application
745                      -- We do this rather than generate an HsCon directly, because
746                      -- it means that the special cases (e.g. dictionary with only one
747                      -- member) are dealt with by the common MkId.mkDataConWrapId
748                      -- code rather than needing to be repeated here.
749                      --    con_app_tys  = MkD ty1 ty2
750                      --    con_app_scs  = MkD ty1 ty2 sc1 sc2
751                      --    con_app_args = MkD ty1 ty2 sc1 sc2 op1 op2
752              con_app_tys  = wrapId (mkWpTyApps inst_tys)
753                                    (dataConWrapId dict_constr)
754              con_app_scs  = mkHsWrap (mkWpEvApps (map mk_sc_ev_term sc_args)) con_app_tys
755              con_app_args = foldl mk_app con_app_scs $
756                             map (wrapId arg_wrapper) meth_ids
757
758              mk_app :: HsExpr Id -> HsExpr Id -> HsExpr Id
759              mk_app fun arg = HsApp (L loc fun) (L loc arg)
760
761              mk_sc_ev_term :: EvVar -> EvTerm
762              mk_sc_ev_term sc
763                | null inst_tv_tys
764                , null dfun_ev_vars = EvId sc
765                | otherwise         = EvDFunApp sc inst_tv_tys dfun_ev_vars
766
767              inst_tv_tys    = mkTyVarTys inst_tyvars
768              arg_wrapper = mkWpEvVarApps dfun_ev_vars <.> mkWpTyApps inst_tv_tys
769
770                 -- Do not inline the dfun; instead give it a magic DFunFunfolding
771                 -- See Note [ClassOp/DFun selection]
772                 -- See also note [Single-method classes]
773              dfun_id_w_fun
774                 | isNewTyCon class_tc
775                 = dfun_id `setInlinePragma` alwaysInlinePragma { inl_sat = Just 0 }
776                 | otherwise
777                 = dfun_id `setIdUnfolding`  mkDFunUnfolding dfun_ty dfun_args
778                           `setInlinePragma` dfunInlinePragma
779
780              dfun_args :: [CoreExpr]
781              dfun_args = map varToCoreExpr sc_args ++
782                          map Var           meth_ids
783
784              export = ABE { abe_wrap = idHsWrapper, abe_poly = dfun_id_w_fun
785                           , abe_mono = self_dict, abe_prags = SpecPrags spec_inst_prags }
786              main_bind = AbsBinds { abs_tvs = inst_tyvars
787                                   , abs_ev_vars = dfun_ev_vars
788                                   , abs_exports = [export]
789                                   , abs_ev_binds = emptyTcEvBinds
790                                   , abs_binds = unitBag dict_bind }
791
792        ; return (unitBag (L loc main_bind) `unionBags`
793                  listToBag meth_binds      `unionBags`
794                  unionManyBags sc_binds)
795        }
796  where
797    dfun_ty   = idType dfun_id
798    dfun_id   = instanceDFunId ispec
799    loc       = getSrcSpan dfun_id
800
801 ------------------------------
802 tcSuperClass :: [TcTyVar] -> [EvVar]
803              -> (Id, PredType)
804              -> TcM (TcId, LHsBinds TcId)
805
806 -- Build a top level decl like
807 --      sc_op = /\a \d. let sc = ... in
808 --                      sc
809 -- and return sc_op, that binding
810
811 tcSuperClass tyvars ev_vars (sc_sel, sc_pred)
812   = do { (ev_binds, sc_dict)
813              <- newImplication InstSkol tyvars ev_vars $
814                 emitWanted ScOrigin sc_pred
815
816        ; uniq <- newUnique
817        ; let sc_op_ty   = mkForAllTys tyvars $ mkPiTypes ev_vars (varType sc_dict)
818              sc_op_name = mkDerivedInternalName mkClassOpAuxOcc uniq
819                                                 (getName sc_sel)
820              sc_op_id   = mkLocalId sc_op_name sc_op_ty
821              sc_op_bind = mkVarBind sc_op_id (L noSrcSpan $ wrapId sc_wrapper sc_dict)
822              sc_wrapper = mkWpTyLams tyvars
823                           <.> mkWpLams ev_vars
824                           <.> mkWpLet ev_binds
825
826        ; return (sc_op_id, unitBag sc_op_bind) }
827
828 ------------------------------
829 tcSpecInstPrags :: DFunId -> InstBindings Name
830                 -> TcM ([Located TcSpecPrag], PragFun)
831 tcSpecInstPrags _ (NewTypeDerived {})
832   = return ([], \_ -> [])
833 tcSpecInstPrags dfun_id (VanillaInst binds uprags _)
834   = do { spec_inst_prags <- mapM (wrapLocM (tcSpecInst dfun_id)) $
835                             filter isSpecInstLSig uprags
836              -- The filter removes the pragmas for methods
837        ; return (spec_inst_prags, mkPragFun uprags binds) }
838 \end{code}
839
840 Note [Superclass loop avoidance]
841 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
842 Consider the following (extreme) situation:
843         class C a => D a where ...
844         instance D [a] => D [a] where ...
845 Although this looks wrong (assume D [a] to prove D [a]), it is only a
846 more extreme case of what happens with recursive dictionaries, and it
847 can, just about, make sense because the methods do some work before
848 recursing.
849
850 To implement the dfun we must generate code for the superclass C [a],
851 which we had better not get by superclass selection from the supplied
852 argument:
853        dfun :: forall a. D [a] -> D [a]
854        dfun = \d::D [a] -> MkD (scsel d) ..
855
856 Rather, we want to get it by finding an instance for (C [a]).  We
857 achieve this by
858     not making the superclasses of a "wanted"
859     available for solving wanted constraints.
860
861 Test case SCLoop tests this fix.
862
863 Note [SPECIALISE instance pragmas]
864 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
865 Consider
866
867    instance (Ix a, Ix b) => Ix (a,b) where
868      {-# SPECIALISE instance Ix (Int,Int) #-}
869      range (x,y) = ...
870
871 We do *not* want to make a specialised version of the dictionary
872 function.  Rather, we want specialised versions of each method.
873 Thus we should generate something like this:
874
875   $dfIx :: (Ix a, Ix x) => Ix (a,b)
876   {- DFUN [$crange, ...] -}
877   $dfIx da db = Ix ($crange da db) (...other methods...)
878
879   $dfIxPair :: (Ix a, Ix x) => Ix (a,b)
880   {- DFUN [$crangePair, ...] -}
881   $dfIxPair = Ix ($crangePair da db) (...other methods...)
882
883   $crange :: (Ix a, Ix b) -> ((a,b),(a,b)) -> [(a,b)]
884   {-# SPECIALISE $crange :: ((Int,Int),(Int,Int)) -> [(Int,Int)] #-}
885   $crange da db = <blah>
886
887   {-# RULE  range ($dfIx da db) = $crange da db #-}
888
889 Note that
890
891   * The RULE is unaffected by the specialisation.  We don't want to
892     specialise $dfIx, because then it would need a specialised RULE
893     which is a pain.  The single RULE works fine at all specialisations.
894     See Note [How instance declarations are translated] above
895
896   * Instead, we want to specialise the *method*, $crange
897
898 In practice, rather than faking up a SPECIALISE pragama for each
899 method (which is painful, since we'd have to figure out its
900 specialised type), we call tcSpecPrag *as if* were going to specialise
901 $dfIx -- you can see that in the call to tcSpecInst.  That generates a
902 SpecPrag which, as it turns out, can be used unchanged for each method.
903 The "it turns out" bit is delicate, but it works fine!
904
905 \begin{code}
906 tcSpecInst :: Id -> Sig Name -> TcM TcSpecPrag
907 tcSpecInst dfun_id prag@(SpecInstSig hs_ty)
908   = addErrCtxt (spec_ctxt prag) $
909     do  { let name = idName dfun_id
910         ; (tyvars, theta, clas, tys) <- tcHsInstHead hs_ty
911         ; let spec_dfun_ty = mkDictFunTy tyvars theta clas tys
912
913         ; co_fn <- tcSubType (SpecPragOrigin name) SpecInstCtxt
914                              (idType dfun_id) spec_dfun_ty
915         ; return (SpecPrag dfun_id co_fn defaultInlinePragma) }
916   where
917     spec_ctxt prag = hang (ptext (sLit "In the SPECIALISE pragma")) 2 (ppr prag)
918
919 tcSpecInst _  _ = panic "tcSpecInst"
920 \end{code}
921
922 %************************************************************************
923 %*                                                                      *
924       Type-checking an instance method
925 %*                                                                      *
926 %************************************************************************
927
928 tcInstanceMethod
929 - Make the method bindings, as a [(NonRec, HsBinds)], one per method
930 - Remembering to use fresh Name (the instance method Name) as the binder
931 - Bring the instance method Ids into scope, for the benefit of tcInstSig
932 - Use sig_fn mapping instance method Name -> instance tyvars
933 - Ditto prag_fn
934 - Use tcValBinds to do the checking
935
936 \begin{code}
937 tcInstanceMethods :: DFunId -> Class -> [TcTyVar]
938                   -> [EvVar]
939                   -> [TcType]
940                   -> ([Located TcSpecPrag], PragFun)
941                   -> [(Id, DefMeth)]
942                   -> InstBindings Name
943                   -> TcM ([Id], [LHsBind Id])
944         -- The returned inst_meth_ids all have types starting
945         --      forall tvs. theta => ...
946 tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
947                   (spec_inst_prags, prag_fn)
948                   op_items (VanillaInst binds _ standalone_deriv)
949   = mapAndUnzipM tc_item op_items
950   where
951     ----------------------
952     tc_item :: (Id, DefMeth) -> TcM (Id, LHsBind Id)
953     tc_item (sel_id, dm_info)
954       = case findMethodBind (idName sel_id) binds of
955             Just user_bind -> tc_body sel_id standalone_deriv user_bind
956             Nothing        -> tc_default sel_id dm_info
957
958     ----------------------
959     tc_body :: Id -> Bool -> LHsBind Name -> TcM (TcId, LHsBind Id)
960     tc_body sel_id generated_code rn_bind
961       = add_meth_ctxt sel_id generated_code rn_bind $
962         do { (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars
963                                                    inst_tys sel_id
964            ; let prags = prag_fn (idName sel_id)
965            ; meth_id1 <- addInlinePrags meth_id prags
966            ; spec_prags <- tcSpecPrags meth_id1 prags
967            ; bind <- tcInstanceMethodBody InstSkol
968                           tyvars dfun_ev_vars
969                           meth_id1 local_meth_id meth_sig_fn
970                           (mk_meth_spec_prags meth_id1 spec_prags)
971                           rn_bind
972            ; return (meth_id1, bind) }
973
974     ----------------------
975     tc_default :: Id -> DefMeth -> TcM (TcId, LHsBind Id)
976
977     tc_default sel_id (GenDefMeth dm_name)
978       = do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id dm_name
979            ; tc_body sel_id False {- Not generated code? -} meth_bind }
980
981     tc_default sel_id NoDefMeth     -- No default method at all
982       = do { warnMissingMethod sel_id
983            ; (meth_id, _) <- mkMethIds clas tyvars dfun_ev_vars
984                                          inst_tys sel_id
985            ; return (meth_id, mkVarBind meth_id $
986                               mkLHsWrap lam_wrapper error_rhs) }
987       where
988         error_rhs    = L loc $ HsApp error_fun error_msg
989         error_fun    = L loc $ wrapId (WpTyApp meth_tau) nO_METHOD_BINDING_ERROR_ID
990         error_msg    = L loc (HsLit (HsStringPrim (mkFastString error_string)))
991         meth_tau     = funResultTy (applyTys (idType sel_id) inst_tys)
992         error_string = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
993         lam_wrapper  = mkWpTyLams tyvars <.> mkWpLams dfun_ev_vars
994
995     tc_default sel_id (DefMeth dm_name) -- A polymorphic default method
996       = do {   -- Build the typechecked version directly,
997                  -- without calling typecheck_method;
998                  -- see Note [Default methods in instances]
999                  -- Generate   /\as.\ds. let self = df as ds
1000                  --                      in $dm inst_tys self
1001                  -- The 'let' is necessary only because HsSyn doesn't allow
1002                  -- you to apply a function to a dictionary *expression*.
1003
1004            ; self_dict <- newDict clas inst_tys
1005            ; let self_ev_bind = EvBind self_dict
1006                                 (EvDFunApp dfun_id (mkTyVarTys tyvars) dfun_ev_vars)
1007
1008            ; (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars
1009                                                    inst_tys sel_id
1010            ; dm_id <- tcLookupId dm_name
1011            ; let dm_inline_prag = idInlinePragma dm_id
1012                  rhs = HsWrap (mkWpEvVarApps [self_dict] <.> mkWpTyApps inst_tys) $
1013                          HsVar dm_id
1014
1015                  meth_bind = mkVarBind local_meth_id (L loc rhs)
1016                  meth_id1 = meth_id `setInlinePragma` dm_inline_prag
1017                         -- Copy the inline pragma (if any) from the default
1018                         -- method to this version. Note [INLINE and default methods]
1019
1020                   
1021                  export = ABE { abe_wrap = idHsWrapper, abe_poly = meth_id1
1022                               , abe_mono = local_meth_id
1023                               , abe_prags = mk_meth_spec_prags meth_id1 [] }
1024                  bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars
1025                                  , abs_exports = [export]
1026                                  , abs_ev_binds = EvBinds (unitBag self_ev_bind)
1027                                  , abs_binds    = unitBag meth_bind }
1028              -- Default methods in an instance declaration can't have their own
1029              -- INLINE or SPECIALISE pragmas. It'd be possible to allow them, but
1030              -- currently they are rejected with
1031              --           "INLINE pragma lacks an accompanying binding"
1032
1033            ; return (meth_id1, L loc bind) }
1034
1035     ----------------------
1036     mk_meth_spec_prags :: Id -> [LTcSpecPrag] -> TcSpecPrags
1037         -- Adapt the SPECIALISE pragmas to work for this method Id
1038         -- There are two sources:
1039         --   * spec_inst_prags: {-# SPECIALISE instance :: <blah> #-}
1040         --     These ones have the dfun inside, but [perhaps surprisingly]
1041         --     the correct wrapper
1042         --   * spec_prags_for_me: {-# SPECIALISE op :: <blah> #-}
1043     mk_meth_spec_prags meth_id spec_prags_for_me
1044       = SpecPrags (spec_prags_for_me ++
1045                    [ L loc (SpecPrag meth_id wrap inl)
1046                    | L loc (SpecPrag _ wrap inl) <- spec_inst_prags])
1047
1048     loc = getSrcSpan dfun_id
1049     meth_sig_fn _ = Just ([],loc)       -- The 'Just' says "yes, there's a type sig"
1050         -- But there are no scoped type variables from local_method_id
1051         -- Only the ones from the instance decl itself, which are already
1052         -- in scope.  Example:
1053         --      class C a where { op :: forall b. Eq b => ... }
1054         --      instance C [c] where { op = <rhs> }
1055         -- In <rhs>, 'c' is scope but 'b' is not!
1056
1057         -- For instance decls that come from standalone deriving clauses
1058         -- we want to print out the full source code if there's an error
1059         -- because otherwise the user won't see the code at all
1060     add_meth_ctxt sel_id generated_code rn_bind thing
1061       | generated_code = addLandmarkErrCtxt (derivBindCtxt sel_id clas inst_tys rn_bind) thing
1062       | otherwise      = thing
1063
1064
1065 tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
1066                   _ op_items (NewTypeDerived coi _)
1067
1068 -- Running example:
1069 --   class Show b => Foo a b where
1070 --     op :: a -> b -> b
1071 --   newtype N a = MkN (Tree [a])
1072 --   deriving instance (Show p, Foo Int p) => Foo Int (N p)
1073 --               -- NB: standalone deriving clause means
1074 --               --     that the contex is user-specified
1075 -- Hence op :: forall a b. Foo a b => a -> b -> b
1076 --
1077 -- We're going to make an instance like
1078 --   instance (Show p, Foo Int p) => Foo Int (N p)
1079 --      op = $copT
1080 --
1081 --   $copT :: forall p. (Show p, Foo Int p) => Int -> N p -> N p
1082 --   $copT p (d1:Show p) (d2:Foo Int p)
1083 --     = op Int (Tree [p]) rep_d |> op_co
1084 --     where
1085 --       rep_d :: Foo Int (Tree [p]) = ...d1...d2...
1086 --       op_co :: (Int -> Tree [p] -> Tree [p]) ~ (Int -> T p -> T p)
1087 -- We get op_co by substituting [Int/a] and [co/b] in type for op
1088 -- where co : [p] ~ T p
1089 --
1090 -- Notice that the dictionary bindings "..d1..d2.." must be generated
1091 -- by the constraint solver, since the <context> may be
1092 -- user-specified.
1093
1094   = do { rep_d_stuff <- checkConstraints InstSkol tyvars dfun_ev_vars $
1095                         emitWanted ScOrigin rep_pred
1096
1097        ; mapAndUnzipM (tc_item rep_d_stuff) op_items }
1098   where
1099      loc = getSrcSpan dfun_id
1100
1101      inst_tvs = fst (tcSplitForAllTys (idType dfun_id))
1102      Just (init_inst_tys, _) = snocView inst_tys
1103      rep_ty   = pFst (coercionKind co)  -- [p]
1104      rep_pred = mkClassPred clas (init_inst_tys ++ [rep_ty])
1105
1106      -- co : [p] ~ T p
1107      co = substCoWithTys (mkInScopeSet (mkVarSet tyvars))
1108                          inst_tvs (mkTyVarTys tyvars) $
1109           mkSymCo coi
1110
1111      ----------------
1112      tc_item :: (TcEvBinds, EvVar) -> (Id, DefMeth) -> TcM (TcId, LHsBind TcId)
1113      tc_item (rep_ev_binds, rep_d) (sel_id, _)
1114        = do { (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars
1115                                                     inst_tys sel_id
1116
1117             ; let meth_rhs  = wrapId (mk_op_wrapper sel_id rep_d) sel_id
1118                   meth_bind = mkVarBind local_meth_id (L loc meth_rhs)
1119                   export = ABE { abe_wrap = idHsWrapper, abe_poly = meth_id
1120                                , abe_mono = local_meth_id, abe_prags = noSpecPrags }
1121                   bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars
1122                                    , abs_exports = [export]
1123                                    , abs_ev_binds = rep_ev_binds
1124                                    , abs_binds = unitBag $ meth_bind }
1125
1126             ; return (meth_id, L loc bind) }
1127
1128      ----------------
1129      mk_op_wrapper :: Id -> EvVar -> HsWrapper
1130      mk_op_wrapper sel_id rep_d
1131        = WpCast (liftCoSubstWith sel_tvs (map mkReflCo init_inst_tys ++ [co])
1132                                  local_meth_ty)
1133          <.> WpEvApp (EvId rep_d)
1134          <.> mkWpTyApps (init_inst_tys ++ [rep_ty])
1135        where
1136          (sel_tvs, sel_rho) = tcSplitForAllTys (idType sel_id)
1137          (_, local_meth_ty) = tcSplitPredFunTy_maybe sel_rho
1138                               `orElse` pprPanic "tcInstanceMethods" (ppr sel_id)
1139
1140 ----------------------
1141 mkMethIds :: Class -> [TcTyVar] -> [EvVar] -> [TcType] -> Id -> TcM (TcId, TcId)
1142 mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id
1143   = do  { uniq <- newUnique
1144         ; let meth_name = mkDerivedInternalName mkClassOpAuxOcc uniq sel_name
1145         ; local_meth_name <- newLocalName sel_name
1146                   -- Base the local_meth_name on the selector name, becuase
1147                   -- type errors from tcInstanceMethodBody come from here
1148
1149         ; let meth_id       = mkLocalId meth_name meth_ty
1150               local_meth_id = mkLocalId local_meth_name local_meth_ty
1151         ; return (meth_id, local_meth_id) }
1152   where
1153     local_meth_ty = instantiateMethod clas sel_id inst_tys
1154     meth_ty = mkForAllTys tyvars $ mkPiTypes dfun_ev_vars local_meth_ty
1155     sel_name = idName sel_id
1156
1157 ----------------------
1158 wrapId :: HsWrapper -> id -> HsExpr id
1159 wrapId wrapper id = mkHsWrap wrapper (HsVar id)
1160
1161 derivBindCtxt :: Id -> Class -> [Type ] -> LHsBind Name -> SDoc
1162 derivBindCtxt sel_id clas tys _bind
1163    = vcat [ ptext (sLit "When typechecking the code for ") <+> quotes (ppr sel_id)
1164           , nest 2 (ptext (sLit "in a standalone derived instance for")
1165                     <+> quotes (pprClassPred clas tys) <> colon)
1166           , nest 2 $ ptext (sLit "To see the code I am typechecking, use -ddump-deriv") ]
1167
1168 -- Too voluminous
1169 --        , nest 2 $ pprSetDepth AllTheWay $ ppr bind ]
1170
1171 warnMissingMethod :: Id -> TcM ()
1172 warnMissingMethod sel_id
1173   = do { warn <- woptM Opt_WarnMissingMethods
1174        ; warnTc (warn  -- Warn only if -fwarn-missing-methods
1175                  && not (startsWithUnderscore (getOccName sel_id)))
1176                                         -- Don't warn about _foo methods
1177                 (ptext (sLit "No explicit method nor default method for")
1178                  <+> quotes (ppr sel_id)) }
1179 \end{code}
1180
1181 Note [Export helper functions]
1182 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1183 We arrange to export the "helper functions" of an instance declaration,
1184 so that they are not subject to preInlineUnconditionally, even if their
1185 RHS is trivial.  Reason: they are mentioned in the DFunUnfolding of
1186 the dict fun as Ids, not as CoreExprs, so we can't substitute a
1187 non-variable for them.
1188
1189 We could change this by making DFunUnfoldings have CoreExprs, but it
1190 seems a bit simpler this way.
1191
1192 Note [Default methods in instances]
1193 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1194 Consider this
1195
1196    class Baz v x where
1197       foo :: x -> x
1198       foo y = <blah>
1199
1200    instance Baz Int Int
1201
1202 From the class decl we get
1203
1204    $dmfoo :: forall v x. Baz v x => x -> x
1205    $dmfoo y = <blah>
1206
1207 Notice that the type is ambiguous.  That's fine, though. The instance
1208 decl generates
1209
1210    $dBazIntInt = MkBaz fooIntInt
1211    fooIntInt = $dmfoo Int Int $dBazIntInt
1212
1213 BUT this does mean we must generate the dictionary translation of
1214 fooIntInt directly, rather than generating source-code and
1215 type-checking it.  That was the bug in Trac #1061. In any case it's
1216 less work to generate the translated version!
1217
1218 Note [INLINE and default methods]
1219 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1220 Default methods need special case.  They are supposed to behave rather like
1221 macros.  For exmample
1222
1223   class Foo a where
1224     op1, op2 :: Bool -> a -> a
1225
1226     {-# INLINE op1 #-}
1227     op1 b x = op2 (not b) x
1228
1229   instance Foo Int where
1230     -- op1 via default method
1231     op2 b x = <blah>
1232
1233 The instance declaration should behave
1234
1235    just as if 'op1' had been defined with the
1236    code, and INLINE pragma, from its original
1237    definition.
1238
1239 That is, just as if you'd written
1240
1241   instance Foo Int where
1242     op2 b x = <blah>
1243
1244     {-# INLINE op1 #-}
1245     op1 b x = op2 (not b) x
1246
1247 So for the above example we generate:
1248
1249
1250   {-# INLINE $dmop1 #-}
1251   -- $dmop1 has an InlineCompulsory unfolding
1252   $dmop1 d b x = op2 d (not b) x
1253
1254   $fFooInt = MkD $cop1 $cop2
1255
1256   {-# INLINE $cop1 #-}
1257   $cop1 = $dmop1 $fFooInt
1258
1259   $cop2 = <blah>
1260
1261 Note carefullly:
1262
1263 * We *copy* any INLINE pragma from the default method $dmop1 to the
1264   instance $cop1.  Otherwise we'll just inline the former in the
1265   latter and stop, which isn't what the user expected
1266
1267 * Regardless of its pragma, we give the default method an
1268   unfolding with an InlineCompulsory source. That means
1269   that it'll be inlined at every use site, notably in
1270   each instance declaration, such as $cop1.  This inlining
1271   must happen even though
1272     a) $dmop1 is not saturated in $cop1
1273     b) $cop1 itself has an INLINE pragma
1274
1275   It's vital that $dmop1 *is* inlined in this way, to allow the mutual
1276   recursion between $fooInt and $cop1 to be broken
1277
1278 * To communicate the need for an InlineCompulsory to the desugarer
1279   (which makes the Unfoldings), we use the IsDefaultMethod constructor
1280   in TcSpecPrags.
1281
1282
1283 %************************************************************************
1284 %*                                                                      *
1285 \subsection{Error messages}
1286 %*                                                                      *
1287 %************************************************************************
1288
1289 \begin{code}
1290 instDeclCtxt1 :: LHsType Name -> SDoc
1291 instDeclCtxt1 hs_inst_ty
1292   = inst_decl_ctxt (case unLoc hs_inst_ty of
1293                         HsForAllTy _ _ _ (L _ ty') -> ppr ty'
1294                         _                          -> ppr hs_inst_ty)     -- Don't expect this
1295 instDeclCtxt2 :: Type -> SDoc
1296 instDeclCtxt2 dfun_ty
1297   = inst_decl_ctxt (ppr (mkClassPred cls tys))
1298   where
1299     (_,_,cls,tys) = tcSplitDFunTy dfun_ty
1300
1301 inst_decl_ctxt :: SDoc -> SDoc
1302 inst_decl_ctxt doc = ptext (sLit "In the instance declaration for") <+> quotes doc
1303
1304 omittedATWarn :: Name -> SDoc
1305 omittedATWarn at
1306   = ptext (sLit "No explicit AT declaration for") <+> quotes (ppr at)
1307
1308 badBootFamInstDeclErr :: SDoc
1309 badBootFamInstDeclErr
1310   = ptext (sLit "Illegal family instance in hs-boot file")
1311
1312 notFamily :: TyCon -> SDoc
1313 notFamily tycon
1314   = vcat [ ptext (sLit "Illegal family instance for") <+> quotes (ppr tycon)
1315          , nest 2 $ parens (ppr tycon <+> ptext (sLit "is not an indexed type family"))]
1316
1317 tooFewParmsErr :: Arity -> SDoc
1318 tooFewParmsErr arity
1319   = ptext (sLit "Family instance has too few parameters; expected") <+>
1320     ppr arity
1321
1322 assocInClassErr :: Located Name -> SDoc
1323 assocInClassErr name
1324  = ptext (sLit "Associated type") <+> quotes (ppr name) <+>
1325    ptext (sLit "must be inside a class instance")
1326
1327 badFamInstDecl :: Located Name -> SDoc
1328 badFamInstDecl tc_name
1329   = vcat [ ptext (sLit "Illegal family instance for") <+>
1330            quotes (ppr tc_name)
1331          , nest 2 (parens $ ptext (sLit "Use -XTypeFamilies to allow indexed type families")) ]
1332 \end{code}