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