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