Merge branch 'master' into fix#5464
[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 (is_cls (iSpec x) `elem` typeableClassNames)
411                                (addErrAt (getSrcSpan $ iSpec x) typInstErr))
412                    local_info
413
414        ; return ( gbl_env
415                 , (bagToList deriv_inst_info) ++ local_info
416                 , aux_binds `plusHsValBinds` deriv_binds)
417     }}}
418   where
419     typInstErr = ptext $ sLit $ "Can't create hand written instances of Typeable in Safe"
420                               ++ " Haskell! Can only derive them"
421
422 addInsts :: [InstInfo Name] -> TcM a -> TcM a
423 addInsts infos thing_inside
424   = tcExtendLocalInstEnv (map iSpec infos) thing_inside
425
426 addFamInsts :: [TyCon] -> TcM a -> TcM a
427 addFamInsts tycons thing_inside
428   = tcExtendLocalFamInstEnv (map mkLocalFamInst tycons) thing_inside
429 \end{code}
430
431 \begin{code}
432 tcLocalInstDecl1 :: LInstDecl Name
433                  -> TcM (InstInfo Name, [TyCon])
434         -- A source-file instance declaration
435         -- Type-check all the stuff before the "where"
436         --
437         -- We check for respectable instance type, and context
438 tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats))
439   = setSrcSpan loc                      $
440     addErrCtxt (instDeclCtxt1 poly_ty)  $
441
442     do  { is_boot <- tcIsHsBoot
443         ; checkTc (not is_boot || (isEmptyLHsBinds binds && null uprags))
444                   badBootDeclErr
445
446         ; (tyvars, theta, clas, inst_tys) <- tcHsInstHead poly_ty
447         ; checkValidInstance poly_ty tyvars theta clas inst_tys
448         ; let mini_env = mkVarEnv (classTyVars clas `zip` inst_tys)
449
450         -- Next, process any associated types.
451         ; traceTc "tcLocalInstDecl" (ppr poly_ty)
452         ; idx_tycons0 <- tcExtendTyVarEnv tyvars $
453                         mapAndRecoverM (tcAssocDecl clas mini_env) ats
454
455         -- Check for misssing associated types and build them
456         -- from their defaults (if available)
457         ; let defined_ats = mkNameSet $ map (tcdName . unLoc) ats
458               check_at_instance (fam_tc, defs)
459                  -- User supplied instances ==> everything is OK
460                 | tyConName fam_tc `elemNameSet` defined_ats = return (Nothing, [])
461                  -- No defaults ==> generate a warning
462                 | null defs                                  = return (Just (tyConName fam_tc), [])
463                  -- No user instance, have defaults ==> instatiate them
464                 | otherwise = do
465                     defs' <- forM defs $ \(ATD tvs pat_tys rhs) -> do
466                       let mini_env_subst = mkTvSubst (mkInScopeSet (mkVarSet tvs)) mini_env
467                           tvs' = varSetElems (tyVarsOfType rhs')
468                           pat_tys' = substTys mini_env_subst pat_tys
469                           rhs' = substTy mini_env_subst rhs
470                       rep_tc_name <- newFamInstTyConName (noLoc (tyConName fam_tc)) pat_tys'
471                       buildSynTyCon rep_tc_name tvs'
472                                     (SynonymTyCon rhs')
473                                     (mkArrowKinds (map tyVarKind tvs') (typeKind rhs'))
474                                     NoParentTyCon (Just (fam_tc, pat_tys'))
475                     return (Nothing, defs')
476         ; missing_at_stuff <- mapM check_at_instance (classATItems clas)
477         
478         ; let (omitted, idx_tycons1) = unzip missing_at_stuff
479         ; warn <- woptM Opt_WarnMissingMethods
480         ; mapM_ (warnTc warn . omittedATWarn) (catMaybes omitted)
481
482         -- Finally, construct the Core representation of the instance.
483         -- (This no longer includes the associated types.)
484         ; dfun_name <- newDFunName clas inst_tys (getLoc poly_ty)
485                 -- Dfun location is that of instance *header*
486
487         ; overlap_flag <- getOverlapFlag
488         ; let dfun      = mkDictFunId dfun_name tyvars theta clas inst_tys
489               ispec     = mkLocalInstance dfun overlap_flag
490               inst_info = InstInfo { iSpec  = ispec, iBinds = VanillaInst binds uprags False }
491
492         ; return (inst_info, idx_tycons0 ++ concat idx_tycons1) }
493 \end{code}
494
495
496 %************************************************************************
497 %*                                                                      *
498                Type checking family instances
499 %*                                                                      *
500 %************************************************************************
501
502 Family instances are somewhat of a hybrid.  They are processed together with
503 class instance heads, but can contain data constructors and hence they share a
504 lot of kinding and type checking code with ordinary algebraic data types (and
505 GADTs).
506
507 \begin{code}
508 tcTopFamInstDecl :: LTyClDecl Name -> TcM TyCon
509 tcTopFamInstDecl (L loc decl)
510   = setSrcSpan loc      $
511     tcAddDeclCtxt decl  $
512     tcFamInstDecl TopLevel decl
513
514 tcFamInstDecl :: TopLevelFlag -> TyClDecl Name -> TcM TyCon
515 tcFamInstDecl top_lvl decl
516   = do { -- type family instances require -XTypeFamilies
517          -- and can't (currently) be in an hs-boot file
518        ; let fam_tc_lname = tcdLName decl
519        ; type_families <- xoptM Opt_TypeFamilies
520        ; is_boot <- tcIsHsBoot   -- Are we compiling an hs-boot file?
521        ; checkTc type_families $ badFamInstDecl fam_tc_lname
522        ; checkTc (not is_boot) $ badBootFamInstDeclErr
523
524        -- Look up the family TyCon and check for validity including
525        -- check that toplevel type instances are not for associated types.
526        ; fam_tc <- tcLookupLocatedTyCon fam_tc_lname
527        ; checkTc (isFamilyTyCon fam_tc) (notFamily fam_tc)
528        ; when (isTopLevel top_lvl && isTyConAssoc fam_tc)
529               (addErr $ assocInClassErr fam_tc_lname)
530
531          -- Now check the type/data instance itself
532          -- This is where type and data decls are treated separately
533        ; tc <- tcFamInstDecl1 fam_tc decl
534        ; checkValidTyCon tc     -- Remember to check validity;
535                                 -- no recursion to worry about here
536
537        ; return tc }
538
539 tcFamInstDecl1 :: TyCon -> TyClDecl Name -> TcM TyCon
540
541   -- "type instance"
542 tcFamInstDecl1 fam_tc (decl@TySynonym {})
543   = kcFamTyPats decl $ \k_tvs k_typats resKind ->
544     do { -- kind check the right-hand side of the type equation
545        ; k_rhs <- kcCheckLHsType (tcdSynRhs decl) (EK resKind EkUnk)
546                   -- ToDo: the ExpKind could be better
547
548          -- (1) do the work of verifying the synonym
549        ; (t_tvs, t_typats, t_rhs) <- tcSynFamInstDecl fam_tc (decl { tcdTyVars = k_tvs, tcdTyPats = Just k_typats, tcdSynRhs = k_rhs })
550
551          -- (2) check the well-formedness of the instance
552        ; checkValidFamInst t_typats t_rhs
553
554          -- (3) construct representation tycon
555        ; rep_tc_name <- newFamInstTyConName (tcdLName decl) t_typats
556        ; buildSynTyCon rep_tc_name t_tvs
557                        (SynonymTyCon t_rhs)
558                        (typeKind t_rhs)
559                        NoParentTyCon (Just (fam_tc, t_typats))
560        }
561
562   -- "newtype instance" and "data instance"
563 tcFamInstDecl1 fam_tc (decl@TyData { tcdND = new_or_data
564                                    , tcdCons = cons})
565   = kcFamTyPats decl $ \k_tvs k_typats resKind ->
566     do { -- check that the family declaration is for the right kind
567          checkTc (isFamilyTyCon fam_tc) (notFamily fam_tc)
568        ; checkTc (isAlgTyCon fam_tc) (wrongKindOfFamily fam_tc)
569
570        ; -- (1) kind check the data declaration as usual
571        ; k_decl <- kcDataDecl decl k_tvs
572        ; let k_ctxt = tcdCtxt k_decl
573              k_cons = tcdCons k_decl
574
575          -- result kind must be '*' (otherwise, we have too few patterns)
576        ; resKind' <- zonkTcKindToKind resKind -- Remember: kcFamTyPats supplies unzonked kind!
577        ; checkTc (isLiftedTypeKind resKind') $ tooFewParmsErr (tyConArity fam_tc)
578
579          -- (2) type check indexed data type declaration
580        ; tcTyVarBndrs k_tvs $ \t_tvs -> do   -- turn kinded into proper tyvars
581
582          -- kind check the type indexes and the context
583        { t_typats     <- mapM tcHsKindedType k_typats
584        ; stupid_theta <- tcHsKindedContext k_ctxt
585
586          -- (3) Check that
587          --     (a) left-hand side contains no type family applications
588          --         (vanilla synonyms are fine, though, and we checked for
589          --         foralls earlier)
590        ; mapM_ checkTyFamFreeness t_typats
591
592        ; dataDeclChecks (tcdName decl) new_or_data stupid_theta k_cons
593
594          -- (4) construct representation tycon
595        ; rep_tc_name <- newFamInstTyConName (tcdLName decl) t_typats
596        ; let ex_ok = True       -- Existentials ok for type families!
597        ; fixM (\ rep_tycon -> do
598              { let orig_res_ty = mkTyConApp fam_tc t_typats
599              ; data_cons <- tcConDecls ex_ok rep_tycon
600                                        (t_tvs, orig_res_ty) k_cons
601              ; tc_rhs <-
602                  case new_or_data of
603                    DataType -> return (mkDataTyConRhs data_cons)
604                    NewType  -> ASSERT( not (null data_cons) )
605                                mkNewTyConRhs rep_tc_name rep_tycon (head data_cons)
606              ; buildAlgTyCon rep_tc_name t_tvs stupid_theta tc_rhs Recursive
607                              h98_syntax NoParentTyCon (Just (fam_tc, t_typats))
608                  -- We always assume that indexed types are recursive.  Why?
609                  -- (1) Due to their open nature, we can never be sure that a
610                  -- further instance might not introduce a new recursive
611                  -- dependency.  (2) They are always valid loop breakers as
612                  -- they involve a coercion.
613              })
614        }}
615        where
616          h98_syntax = case cons of      -- All constructors have same shape
617                         L _ (ConDecl { con_res = ResTyGADT _ }) : _ -> False
618                         _ -> True
619
620 tcFamInstDecl1 _ d = pprPanic "tcFamInstDecl1" (ppr d)
621
622
623 ----------------
624 tcAssocDecl :: Class           -- ^ Class of associated type
625             -> VarEnv Type     -- ^ Instantiation of class TyVars
626             -> LTyClDecl Name  -- ^ RHS
627             -> TcM TyCon
628 tcAssocDecl clas mini_env (L loc decl)
629   = setSrcSpan loc      $
630     tcAddDeclCtxt decl  $
631     do { at_tc <- tcFamInstDecl NotTopLevel decl
632        ; let Just (fam_tc, at_tys) = tyConFamInst_maybe at_tc
633   
634        -- Check that the associated type comes from this class
635        ; checkTc (Just clas == tyConAssoc_maybe fam_tc)
636                  (badATErr clas (tyConName at_tc))
637
638        -- See Note [Checking consistent instantiation]
639        ; zipWithM_ check_arg (tyConTyVars fam_tc) at_tys
640
641        ; return at_tc }
642   where
643     check_arg fam_tc_tv at_ty
644       | Just inst_ty <- lookupVarEnv mini_env fam_tc_tv
645       = checkTc (inst_ty `eqType` at_ty) 
646                 (wrongATArgErr at_ty inst_ty)
647       | otherwise
648       = return ()   -- Allow non-type-variable instantiation
649                     -- See Note [Associated type instances]
650 \end{code}
651
652
653 %************************************************************************
654 %*                                                                      *
655       Type-checking instance declarations, pass 2
656 %*                                                                      *
657 %************************************************************************
658
659 \begin{code}
660 tcInstDecls2 :: [LTyClDecl Name] -> [InstInfo Name]
661              -> TcM (LHsBinds Id)
662 -- (a) From each class declaration,
663 --      generate any default-method bindings
664 -- (b) From each instance decl
665 --      generate the dfun binding
666
667 tcInstDecls2 tycl_decls inst_decls
668   = do  { -- (a) Default methods from class decls
669           let class_decls = filter (isClassDecl . unLoc) tycl_decls
670         ; dm_binds_s <- mapM tcClassDecl2 class_decls
671         ; let dm_binds = unionManyBags dm_binds_s
672
673           -- (b) instance declarations
674         ; let dm_ids = collectHsBindsBinders dm_binds
675               -- Add the default method Ids (again)
676               -- See Note [Default methods and instances]
677         ; inst_binds_s <- tcExtendLetEnv TopLevel dm_ids $
678                           mapM tcInstDecl2 inst_decls
679
680           -- Done
681         ; return (dm_binds `unionBags` unionManyBags inst_binds_s) }
682 \end{code}
683
684 See Note [Default methods and instances]
685 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
686 The default method Ids are already in the type environment (see Note
687 [Default method Ids and Template Haskell] in TcTyClsDcls), BUT they
688 don't have their InlinePragmas yet.  Usually that would not matter,
689 because the simplifier propagates information from binding site to
690 use.  But, unusually, when compiling instance decls we *copy* the
691 INLINE pragma from the default method to the method for that
692 particular operation (see Note [INLINE and default methods] below).
693
694 So right here in tcInstDecls2 we must re-extend the type envt with
695 the default method Ids replete with their INLINE pragmas.  Urk.
696
697 \begin{code}
698
699 tcInstDecl2 :: InstInfo Name -> TcM (LHsBinds Id)
700             -- Returns a binding for the dfun
701 tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
702   = recoverM (return emptyLHsBinds)             $
703     setSrcSpan loc                              $
704     addErrCtxt (instDeclCtxt2 (idType dfun_id)) $
705     do {  -- Instantiate the instance decl with skolem constants
706        ; (inst_tyvars, dfun_theta, inst_head) <- tcSkolDFunType (idType dfun_id)
707                      -- We instantiate the dfun_id with superSkolems.
708                      -- See Note [Subtle interaction of recursion and overlap]
709                      -- and Note [Binding when looking up instances]
710        ; let (clas, inst_tys) = tcSplitDFunHead inst_head
711              (class_tyvars, sc_theta, sc_sels, op_items) = classBigSig clas
712              sc_theta' = substTheta (zipOpenTvSubst class_tyvars inst_tys) sc_theta
713        ; dfun_ev_vars <- newEvVars dfun_theta
714
715        ; (sc_args, sc_binds)
716              <- mapAndUnzipM (tcSuperClass inst_tyvars dfun_ev_vars)
717                               (sc_sels `zip` sc_theta')
718
719        -- Deal with 'SPECIALISE instance' pragmas
720        -- See Note [SPECIALISE instance pragmas]
721        ; spec_info@(spec_inst_prags,_) <- tcSpecInstPrags dfun_id ibinds
722
723         -- Typecheck the methods
724        ; (meth_ids, meth_binds)
725            <- tcExtendTyVarEnv inst_tyvars $
726                 -- The inst_tyvars scope over the 'where' part
727                 -- Those tyvars are inside the dfun_id's type, which is a bit
728                 -- bizarre, but OK so long as you realise it!
729               tcInstanceMethods dfun_id clas inst_tyvars dfun_ev_vars
730                                 inst_tys spec_info
731                                 op_items ibinds
732
733        -- Create the result bindings
734        ; self_dict <- newDict clas inst_tys
735        ; let class_tc      = classTyCon clas
736              [dict_constr] = tyConDataCons class_tc
737              dict_bind     = mkVarBind self_dict (L loc con_app_args)
738
739                      -- We don't produce a binding for the dict_constr; instead we
740                      -- rely on the simplifier to unfold this saturated application
741                      -- We do this rather than generate an HsCon directly, because
742                      -- it means that the special cases (e.g. dictionary with only one
743                      -- member) are dealt with by the common MkId.mkDataConWrapId
744                      -- code rather than needing to be repeated here.
745                      --    con_app_tys  = MkD ty1 ty2
746                      --    con_app_scs  = MkD ty1 ty2 sc1 sc2
747                      --    con_app_args = MkD ty1 ty2 sc1 sc2 op1 op2
748              con_app_tys  = wrapId (mkWpTyApps inst_tys)
749                                    (dataConWrapId dict_constr)
750              con_app_scs  = mkHsWrap (mkWpEvApps (map mk_sc_ev_term sc_args)) con_app_tys
751              con_app_args = foldl mk_app con_app_scs $
752                             map (wrapId arg_wrapper) meth_ids
753
754              mk_app :: HsExpr Id -> HsExpr Id -> HsExpr Id
755              mk_app fun arg = HsApp (L loc fun) (L loc arg)
756
757              mk_sc_ev_term :: EvVar -> EvTerm
758              mk_sc_ev_term sc
759                | null inst_tv_tys
760                , null dfun_ev_vars = EvId sc
761                | otherwise         = EvDFunApp sc inst_tv_tys dfun_ev_vars
762
763              inst_tv_tys    = mkTyVarTys inst_tyvars
764              arg_wrapper = mkWpEvVarApps dfun_ev_vars <.> mkWpTyApps inst_tv_tys
765
766                 -- Do not inline the dfun; instead give it a magic DFunFunfolding
767                 -- See Note [ClassOp/DFun selection]
768                 -- See also note [Single-method classes]
769              dfun_id_w_fun
770                 | isNewTyCon class_tc
771                 = dfun_id `setInlinePragma` alwaysInlinePragma { inl_sat = Just 0 }
772                 | otherwise
773                 = dfun_id `setIdUnfolding`  mkDFunUnfolding dfun_ty dfun_args
774                           `setInlinePragma` dfunInlinePragma
775
776              dfun_args :: [CoreExpr]
777              dfun_args = map varToCoreExpr sc_args ++
778                          map Var           meth_ids
779
780              export = ABE { abe_wrap = idHsWrapper, abe_poly = dfun_id_w_fun
781                           , abe_mono = self_dict, abe_prags = SpecPrags spec_inst_prags }
782              main_bind = AbsBinds { abs_tvs = inst_tyvars
783                                   , abs_ev_vars = dfun_ev_vars
784                                   , abs_exports = [export]
785                                   , abs_ev_binds = emptyTcEvBinds
786                                   , abs_binds = unitBag dict_bind }
787
788        ; return (unitBag (L loc main_bind) `unionBags`
789                  listToBag meth_binds      `unionBags`
790                  unionManyBags sc_binds)
791        }
792  where
793    dfun_ty   = idType dfun_id
794    dfun_id   = instanceDFunId ispec
795    loc       = getSrcSpan dfun_id
796
797 ------------------------------
798 tcSuperClass :: [TcTyVar] -> [EvVar]
799              -> (Id, PredType)
800              -> TcM (TcId, LHsBinds TcId)
801
802 -- Build a top level decl like
803 --      sc_op = /\a \d. let sc = ... in
804 --                      sc
805 -- and return sc_op, that binding
806
807 tcSuperClass tyvars ev_vars (sc_sel, sc_pred)
808   = do { (ev_binds, sc_dict)
809              <- newImplication InstSkol tyvars ev_vars $
810                 emitWanted ScOrigin sc_pred
811
812        ; uniq <- newUnique
813        ; let sc_op_ty   = mkForAllTys tyvars $ mkPiTypes ev_vars (varType sc_dict)
814              sc_op_name = mkDerivedInternalName mkClassOpAuxOcc uniq
815                                                 (getName sc_sel)
816              sc_op_id   = mkLocalId sc_op_name sc_op_ty
817              sc_op_bind = mkVarBind sc_op_id (L noSrcSpan $ wrapId sc_wrapper sc_dict)
818              sc_wrapper = mkWpTyLams tyvars
819                           <.> mkWpLams ev_vars
820                           <.> mkWpLet ev_binds
821
822        ; return (sc_op_id, unitBag sc_op_bind) }
823
824 ------------------------------
825 tcSpecInstPrags :: DFunId -> InstBindings Name
826                 -> TcM ([Located TcSpecPrag], PragFun)
827 tcSpecInstPrags _ (NewTypeDerived {})
828   = return ([], \_ -> [])
829 tcSpecInstPrags dfun_id (VanillaInst binds uprags _)
830   = do { spec_inst_prags <- mapM (wrapLocM (tcSpecInst dfun_id)) $
831                             filter isSpecInstLSig uprags
832              -- The filter removes the pragmas for methods
833        ; return (spec_inst_prags, mkPragFun uprags binds) }
834 \end{code}
835
836 Note [Superclass loop avoidance]
837 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
838 Consider the following (extreme) situation:
839         class C a => D a where ...
840         instance D [a] => D [a] where ...
841 Although this looks wrong (assume D [a] to prove D [a]), it is only a
842 more extreme case of what happens with recursive dictionaries, and it
843 can, just about, make sense because the methods do some work before
844 recursing.
845
846 To implement the dfun we must generate code for the superclass C [a],
847 which we had better not get by superclass selection from the supplied
848 argument:
849        dfun :: forall a. D [a] -> D [a]
850        dfun = \d::D [a] -> MkD (scsel d) ..
851
852 Rather, we want to get it by finding an instance for (C [a]).  We
853 achieve this by
854     not making the superclasses of a "wanted"
855     available for solving wanted constraints.
856
857 Test case SCLoop tests this fix.
858
859 Note [SPECIALISE instance pragmas]
860 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
861 Consider
862
863    instance (Ix a, Ix b) => Ix (a,b) where
864      {-# SPECIALISE instance Ix (Int,Int) #-}
865      range (x,y) = ...
866
867 We do *not* want to make a specialised version of the dictionary
868 function.  Rather, we want specialised versions of each method.
869 Thus we should generate something like this:
870
871   $dfIx :: (Ix a, Ix x) => Ix (a,b)
872   {- DFUN [$crange, ...] -}
873   $dfIx da db = Ix ($crange da db) (...other methods...)
874
875   $dfIxPair :: (Ix a, Ix x) => Ix (a,b)
876   {- DFUN [$crangePair, ...] -}
877   $dfIxPair = Ix ($crangePair da db) (...other methods...)
878
879   $crange :: (Ix a, Ix b) -> ((a,b),(a,b)) -> [(a,b)]
880   {-# SPECIALISE $crange :: ((Int,Int),(Int,Int)) -> [(Int,Int)] #-}
881   $crange da db = <blah>
882
883   {-# RULE  range ($dfIx da db) = $crange da db #-}
884
885 Note that
886
887   * The RULE is unaffected by the specialisation.  We don't want to
888     specialise $dfIx, because then it would need a specialised RULE
889     which is a pain.  The single RULE works fine at all specialisations.
890     See Note [How instance declarations are translated] above
891
892   * Instead, we want to specialise the *method*, $crange
893
894 In practice, rather than faking up a SPECIALISE pragama for each
895 method (which is painful, since we'd have to figure out its
896 specialised type), we call tcSpecPrag *as if* were going to specialise
897 $dfIx -- you can see that in the call to tcSpecInst.  That generates a
898 SpecPrag which, as it turns out, can be used unchanged for each method.
899 The "it turns out" bit is delicate, but it works fine!
900
901 \begin{code}
902 tcSpecInst :: Id -> Sig Name -> TcM TcSpecPrag
903 tcSpecInst dfun_id prag@(SpecInstSig hs_ty)
904   = addErrCtxt (spec_ctxt prag) $
905     do  { let name = idName dfun_id
906         ; (tyvars, theta, clas, tys) <- tcHsInstHead hs_ty
907         ; let spec_dfun_ty = mkDictFunTy tyvars theta clas tys
908
909         ; co_fn <- tcSubType (SpecPragOrigin name) SpecInstCtxt
910                              (idType dfun_id) spec_dfun_ty
911         ; return (SpecPrag dfun_id co_fn defaultInlinePragma) }
912   where
913     spec_ctxt prag = hang (ptext (sLit "In the SPECIALISE pragma")) 2 (ppr prag)
914
915 tcSpecInst _  _ = panic "tcSpecInst"
916 \end{code}
917
918 %************************************************************************
919 %*                                                                      *
920       Type-checking an instance method
921 %*                                                                      *
922 %************************************************************************
923
924 tcInstanceMethod
925 - Make the method bindings, as a [(NonRec, HsBinds)], one per method
926 - Remembering to use fresh Name (the instance method Name) as the binder
927 - Bring the instance method Ids into scope, for the benefit of tcInstSig
928 - Use sig_fn mapping instance method Name -> instance tyvars
929 - Ditto prag_fn
930 - Use tcValBinds to do the checking
931
932 \begin{code}
933 tcInstanceMethods :: DFunId -> Class -> [TcTyVar]
934                   -> [EvVar]
935                   -> [TcType]
936                   -> ([Located TcSpecPrag], PragFun)
937                   -> [(Id, DefMeth)]
938                   -> InstBindings Name
939                   -> TcM ([Id], [LHsBind Id])
940         -- The returned inst_meth_ids all have types starting
941         --      forall tvs. theta => ...
942 tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
943                   (spec_inst_prags, prag_fn)
944                   op_items (VanillaInst binds _ standalone_deriv)
945   = mapAndUnzipM tc_item op_items
946   where
947     ----------------------
948     tc_item :: (Id, DefMeth) -> TcM (Id, LHsBind Id)
949     tc_item (sel_id, dm_info)
950       = case findMethodBind (idName sel_id) binds of
951             Just user_bind -> tc_body sel_id standalone_deriv user_bind
952             Nothing        -> tc_default sel_id dm_info
953
954     ----------------------
955     tc_body :: Id -> Bool -> LHsBind Name -> TcM (TcId, LHsBind Id)
956     tc_body sel_id generated_code rn_bind
957       = add_meth_ctxt sel_id generated_code rn_bind $
958         do { (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars
959                                                    inst_tys sel_id
960            ; let prags = prag_fn (idName sel_id)
961            ; meth_id1 <- addInlinePrags meth_id prags
962            ; spec_prags <- tcSpecPrags meth_id1 prags
963            ; bind <- tcInstanceMethodBody InstSkol
964                           tyvars dfun_ev_vars
965                           meth_id1 local_meth_id meth_sig_fn
966                           (mk_meth_spec_prags meth_id1 spec_prags)
967                           rn_bind
968            ; return (meth_id1, bind) }
969
970     ----------------------
971     tc_default :: Id -> DefMeth -> TcM (TcId, LHsBind Id)
972
973     tc_default sel_id (GenDefMeth dm_name)
974       = do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id dm_name
975            ; tc_body sel_id False {- Not generated code? -} meth_bind }
976
977     tc_default sel_id NoDefMeth     -- No default method at all
978       = do { warnMissingMethod sel_id
979            ; (meth_id, _) <- mkMethIds clas tyvars dfun_ev_vars
980                                          inst_tys sel_id
981            ; return (meth_id, mkVarBind meth_id $
982                               mkLHsWrap lam_wrapper error_rhs) }
983       where
984         error_rhs    = L loc $ HsApp error_fun error_msg
985         error_fun    = L loc $ wrapId (WpTyApp meth_tau) nO_METHOD_BINDING_ERROR_ID
986         error_msg    = L loc (HsLit (HsStringPrim (mkFastString error_string)))
987         meth_tau     = funResultTy (applyTys (idType sel_id) inst_tys)
988         error_string = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
989         lam_wrapper  = mkWpTyLams tyvars <.> mkWpLams dfun_ev_vars
990
991     tc_default sel_id (DefMeth dm_name) -- A polymorphic default method
992       = do {   -- Build the typechecked version directly,
993                  -- without calling typecheck_method;
994                  -- see Note [Default methods in instances]
995                  -- Generate   /\as.\ds. let self = df as ds
996                  --                      in $dm inst_tys self
997                  -- The 'let' is necessary only because HsSyn doesn't allow
998                  -- you to apply a function to a dictionary *expression*.
999
1000            ; self_dict <- newDict clas inst_tys
1001            ; let self_ev_bind = EvBind self_dict
1002                                 (EvDFunApp dfun_id (mkTyVarTys tyvars) dfun_ev_vars)
1003
1004            ; (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars
1005                                                    inst_tys sel_id
1006            ; dm_id <- tcLookupId dm_name
1007            ; let dm_inline_prag = idInlinePragma dm_id
1008                  rhs = HsWrap (mkWpEvVarApps [self_dict] <.> mkWpTyApps inst_tys) $
1009                          HsVar dm_id
1010
1011                  meth_bind = mkVarBind local_meth_id (L loc rhs)
1012                  meth_id1 = meth_id `setInlinePragma` dm_inline_prag
1013                         -- Copy the inline pragma (if any) from the default
1014                         -- method to this version. Note [INLINE and default methods]
1015
1016                   
1017                  export = ABE { abe_wrap = idHsWrapper, abe_poly = meth_id1
1018                               , abe_mono = local_meth_id
1019                               , abe_prags = mk_meth_spec_prags meth_id1 [] }
1020                  bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars
1021                                  , abs_exports = [export]
1022                                  , abs_ev_binds = EvBinds (unitBag self_ev_bind)
1023                                  , abs_binds    = unitBag meth_bind }
1024              -- Default methods in an instance declaration can't have their own
1025              -- INLINE or SPECIALISE pragmas. It'd be possible to allow them, but
1026              -- currently they are rejected with
1027              --           "INLINE pragma lacks an accompanying binding"
1028
1029            ; return (meth_id1, L loc bind) }
1030
1031     ----------------------
1032     mk_meth_spec_prags :: Id -> [LTcSpecPrag] -> TcSpecPrags
1033         -- Adapt the SPECIALISE pragmas to work for this method Id
1034         -- There are two sources:
1035         --   * spec_inst_prags: {-# SPECIALISE instance :: <blah> #-}
1036         --     These ones have the dfun inside, but [perhaps surprisingly]
1037         --     the correct wrapper
1038         --   * spec_prags_for_me: {-# SPECIALISE op :: <blah> #-}
1039     mk_meth_spec_prags meth_id spec_prags_for_me
1040       = SpecPrags (spec_prags_for_me ++
1041                    [ L loc (SpecPrag meth_id wrap inl)
1042                    | L loc (SpecPrag _ wrap inl) <- spec_inst_prags])
1043
1044     loc = getSrcSpan dfun_id
1045     meth_sig_fn _ = Just ([],loc)       -- The 'Just' says "yes, there's a type sig"
1046         -- But there are no scoped type variables from local_method_id
1047         -- Only the ones from the instance decl itself, which are already
1048         -- in scope.  Example:
1049         --      class C a where { op :: forall b. Eq b => ... }
1050         --      instance C [c] where { op = <rhs> }
1051         -- In <rhs>, 'c' is scope but 'b' is not!
1052
1053         -- For instance decls that come from standalone deriving clauses
1054         -- we want to print out the full source code if there's an error
1055         -- because otherwise the user won't see the code at all
1056     add_meth_ctxt sel_id generated_code rn_bind thing
1057       | generated_code = addLandmarkErrCtxt (derivBindCtxt sel_id clas inst_tys rn_bind) thing
1058       | otherwise      = thing
1059
1060
1061 tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
1062                   _ op_items (NewTypeDerived coi _)
1063
1064 -- Running example:
1065 --   class Show b => Foo a b where
1066 --     op :: a -> b -> b
1067 --   newtype N a = MkN (Tree [a])
1068 --   deriving instance (Show p, Foo Int p) => Foo Int (N p)
1069 --               -- NB: standalone deriving clause means
1070 --               --     that the contex is user-specified
1071 -- Hence op :: forall a b. Foo a b => a -> b -> b
1072 --
1073 -- We're going to make an instance like
1074 --   instance (Show p, Foo Int p) => Foo Int (N p)
1075 --      op = $copT
1076 --
1077 --   $copT :: forall p. (Show p, Foo Int p) => Int -> N p -> N p
1078 --   $copT p (d1:Show p) (d2:Foo Int p)
1079 --     = op Int (Tree [p]) rep_d |> op_co
1080 --     where
1081 --       rep_d :: Foo Int (Tree [p]) = ...d1...d2...
1082 --       op_co :: (Int -> Tree [p] -> Tree [p]) ~ (Int -> T p -> T p)
1083 -- We get op_co by substituting [Int/a] and [co/b] in type for op
1084 -- where co : [p] ~ T p
1085 --
1086 -- Notice that the dictionary bindings "..d1..d2.." must be generated
1087 -- by the constraint solver, since the <context> may be
1088 -- user-specified.
1089
1090   = do { rep_d_stuff <- checkConstraints InstSkol tyvars dfun_ev_vars $
1091                         emitWanted ScOrigin rep_pred
1092
1093        ; mapAndUnzipM (tc_item rep_d_stuff) op_items }
1094   where
1095      loc = getSrcSpan dfun_id
1096
1097      inst_tvs = fst (tcSplitForAllTys (idType dfun_id))
1098      Just (init_inst_tys, _) = snocView inst_tys
1099      rep_ty   = pFst (coercionKind co)  -- [p]
1100      rep_pred = mkClassPred clas (init_inst_tys ++ [rep_ty])
1101
1102      -- co : [p] ~ T p
1103      co = substCoWithTys (mkInScopeSet (mkVarSet tyvars))
1104                          inst_tvs (mkTyVarTys tyvars) $
1105           mkSymCo coi
1106
1107      ----------------
1108      tc_item :: (TcEvBinds, EvVar) -> (Id, DefMeth) -> TcM (TcId, LHsBind TcId)
1109      tc_item (rep_ev_binds, rep_d) (sel_id, _)
1110        = do { (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars
1111                                                     inst_tys sel_id
1112
1113             ; let meth_rhs  = wrapId (mk_op_wrapper sel_id rep_d) sel_id
1114                   meth_bind = mkVarBind local_meth_id (L loc meth_rhs)
1115                   export = ABE { abe_wrap = idHsWrapper, abe_poly = meth_id
1116                                , abe_mono = local_meth_id, abe_prags = noSpecPrags }
1117                   bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars
1118                                    , abs_exports = [export]
1119                                    , abs_ev_binds = rep_ev_binds
1120                                    , abs_binds = unitBag $ meth_bind }
1121
1122             ; return (meth_id, L loc bind) }
1123
1124      ----------------
1125      mk_op_wrapper :: Id -> EvVar -> HsWrapper
1126      mk_op_wrapper sel_id rep_d
1127        = WpCast (liftCoSubstWith sel_tvs (map mkReflCo init_inst_tys ++ [co])
1128                                  local_meth_ty)
1129          <.> WpEvApp (EvId rep_d)
1130          <.> mkWpTyApps (init_inst_tys ++ [rep_ty])
1131        where
1132          (sel_tvs, sel_rho) = tcSplitForAllTys (idType sel_id)
1133          (_, local_meth_ty) = tcSplitPredFunTy_maybe sel_rho
1134                               `orElse` pprPanic "tcInstanceMethods" (ppr sel_id)
1135
1136 ----------------------
1137 mkMethIds :: Class -> [TcTyVar] -> [EvVar] -> [TcType] -> Id -> TcM (TcId, TcId)
1138 mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id
1139   = do  { uniq <- newUnique
1140         ; let meth_name = mkDerivedInternalName mkClassOpAuxOcc uniq sel_name
1141         ; local_meth_name <- newLocalName sel_name
1142                   -- Base the local_meth_name on the selector name, becuase
1143                   -- type errors from tcInstanceMethodBody come from here
1144
1145         ; let meth_id       = mkLocalId meth_name meth_ty
1146               local_meth_id = mkLocalId local_meth_name local_meth_ty
1147         ; return (meth_id, local_meth_id) }
1148   where
1149     local_meth_ty = instantiateMethod clas sel_id inst_tys
1150     meth_ty = mkForAllTys tyvars $ mkPiTypes dfun_ev_vars local_meth_ty
1151     sel_name = idName sel_id
1152
1153 ----------------------
1154 wrapId :: HsWrapper -> id -> HsExpr id
1155 wrapId wrapper id = mkHsWrap wrapper (HsVar id)
1156
1157 derivBindCtxt :: Id -> Class -> [Type ] -> LHsBind Name -> SDoc
1158 derivBindCtxt sel_id clas tys _bind
1159    = vcat [ ptext (sLit "When typechecking the code for ") <+> quotes (ppr sel_id)
1160           , nest 2 (ptext (sLit "in a standalone derived instance for")
1161                     <+> quotes (pprClassPred clas tys) <> colon)
1162           , nest 2 $ ptext (sLit "To see the code I am typechecking, use -ddump-deriv") ]
1163
1164 -- Too voluminous
1165 --        , nest 2 $ pprSetDepth AllTheWay $ ppr bind ]
1166
1167 warnMissingMethod :: Id -> TcM ()
1168 warnMissingMethod sel_id
1169   = do { warn <- woptM Opt_WarnMissingMethods
1170        ; warnTc (warn  -- Warn only if -fwarn-missing-methods
1171                  && not (startsWithUnderscore (getOccName sel_id)))
1172                                         -- Don't warn about _foo methods
1173                 (ptext (sLit "No explicit method nor default method for")
1174                  <+> quotes (ppr sel_id)) }
1175 \end{code}
1176
1177 Note [Export helper functions]
1178 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1179 We arrange to export the "helper functions" of an instance declaration,
1180 so that they are not subject to preInlineUnconditionally, even if their
1181 RHS is trivial.  Reason: they are mentioned in the DFunUnfolding of
1182 the dict fun as Ids, not as CoreExprs, so we can't substitute a
1183 non-variable for them.
1184
1185 We could change this by making DFunUnfoldings have CoreExprs, but it
1186 seems a bit simpler this way.
1187
1188 Note [Default methods in instances]
1189 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1190 Consider this
1191
1192    class Baz v x where
1193       foo :: x -> x
1194       foo y = <blah>
1195
1196    instance Baz Int Int
1197
1198 From the class decl we get
1199
1200    $dmfoo :: forall v x. Baz v x => x -> x
1201    $dmfoo y = <blah>
1202
1203 Notice that the type is ambiguous.  That's fine, though. The instance
1204 decl generates
1205
1206    $dBazIntInt = MkBaz fooIntInt
1207    fooIntInt = $dmfoo Int Int $dBazIntInt
1208
1209 BUT this does mean we must generate the dictionary translation of
1210 fooIntInt directly, rather than generating source-code and
1211 type-checking it.  That was the bug in Trac #1061. In any case it's
1212 less work to generate the translated version!
1213
1214 Note [INLINE and default methods]
1215 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1216 Default methods need special case.  They are supposed to behave rather like
1217 macros.  For exmample
1218
1219   class Foo a where
1220     op1, op2 :: Bool -> a -> a
1221
1222     {-# INLINE op1 #-}
1223     op1 b x = op2 (not b) x
1224
1225   instance Foo Int where
1226     -- op1 via default method
1227     op2 b x = <blah>
1228
1229 The instance declaration should behave
1230
1231    just as if 'op1' had been defined with the
1232    code, and INLINE pragma, from its original
1233    definition.
1234
1235 That is, just as if you'd written
1236
1237   instance Foo Int where
1238     op2 b x = <blah>
1239
1240     {-# INLINE op1 #-}
1241     op1 b x = op2 (not b) x
1242
1243 So for the above example we generate:
1244
1245
1246   {-# INLINE $dmop1 #-}
1247   -- $dmop1 has an InlineCompulsory unfolding
1248   $dmop1 d b x = op2 d (not b) x
1249
1250   $fFooInt = MkD $cop1 $cop2
1251
1252   {-# INLINE $cop1 #-}
1253   $cop1 = $dmop1 $fFooInt
1254
1255   $cop2 = <blah>
1256
1257 Note carefullly:
1258
1259 * We *copy* any INLINE pragma from the default method $dmop1 to the
1260   instance $cop1.  Otherwise we'll just inline the former in the
1261   latter and stop, which isn't what the user expected
1262
1263 * Regardless of its pragma, we give the default method an
1264   unfolding with an InlineCompulsory source. That means
1265   that it'll be inlined at every use site, notably in
1266   each instance declaration, such as $cop1.  This inlining
1267   must happen even though
1268     a) $dmop1 is not saturated in $cop1
1269     b) $cop1 itself has an INLINE pragma
1270
1271   It's vital that $dmop1 *is* inlined in this way, to allow the mutual
1272   recursion between $fooInt and $cop1 to be broken
1273
1274 * To communicate the need for an InlineCompulsory to the desugarer
1275   (which makes the Unfoldings), we use the IsDefaultMethod constructor
1276   in TcSpecPrags.
1277
1278
1279 %************************************************************************
1280 %*                                                                      *
1281 \subsection{Error messages}
1282 %*                                                                      *
1283 %************************************************************************
1284
1285 \begin{code}
1286 instDeclCtxt1 :: LHsType Name -> SDoc
1287 instDeclCtxt1 hs_inst_ty
1288   = inst_decl_ctxt (case unLoc hs_inst_ty of
1289                         HsForAllTy _ _ _ (L _ ty') -> ppr ty'
1290                         _                          -> ppr hs_inst_ty)     -- Don't expect this
1291 instDeclCtxt2 :: Type -> SDoc
1292 instDeclCtxt2 dfun_ty
1293   = inst_decl_ctxt (ppr (mkClassPred cls tys))
1294   where
1295     (_,_,cls,tys) = tcSplitDFunTy dfun_ty
1296
1297 inst_decl_ctxt :: SDoc -> SDoc
1298 inst_decl_ctxt doc = ptext (sLit "In the instance declaration for") <+> quotes doc
1299
1300 omittedATWarn :: Name -> SDoc
1301 omittedATWarn at
1302   = ptext (sLit "No explicit AT declaration for") <+> quotes (ppr at)
1303
1304 badBootFamInstDeclErr :: SDoc
1305 badBootFamInstDeclErr
1306   = ptext (sLit "Illegal family instance in hs-boot file")
1307
1308 notFamily :: TyCon -> SDoc
1309 notFamily tycon
1310   = vcat [ ptext (sLit "Illegal family instance for") <+> quotes (ppr tycon)
1311          , nest 2 $ parens (ppr tycon <+> ptext (sLit "is not an indexed type family"))]
1312
1313 tooFewParmsErr :: Arity -> SDoc
1314 tooFewParmsErr arity
1315   = ptext (sLit "Family instance has too few parameters; expected") <+>
1316     ppr arity
1317
1318 assocInClassErr :: Located Name -> SDoc
1319 assocInClassErr name
1320  = ptext (sLit "Associated type") <+> quotes (ppr name) <+>
1321    ptext (sLit "must be inside a class instance")
1322
1323 badFamInstDecl :: Located Name -> SDoc
1324 badFamInstDecl tc_name
1325   = vcat [ ptext (sLit "Illegal family instance for") <+>
1326            quotes (ppr tc_name)
1327          , nest 2 (parens $ ptext (sLit "Use -XTypeFamilies to allow indexed type families")) ]
1328 \end{code}