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