Fix variable name typo from commit 3021fb
[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 {-# LANGUAGE CPP #-}
10 {-# OPTIONS_GHC -fno-warn-tabs #-}
11 -- The above warning supression flag is a temporary kludge.
12 -- While working on this module you are encouraged to remove it and
13 -- detab the module (please do the detabbing in a separate patch). See
14 --     http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
15 -- for details
16
17 module TcInstDcls ( tcInstDecls1, tcInstDecls2 ) where
18
19 #include "HsVersions.h"
20
21 import HsSyn
22 import TcBinds
23 import TcTyClsDecls
24 import TcClassDcl( tcClassDecl2, 
25                    HsSigFun, lookupHsSig, mkHsSigFun,
26                    findMethodBind, instantiateMethod, tcInstanceMethodBody )
27 import TcPat      ( addInlinePrags )
28 import TcRnMonad
29 import TcValidity
30 import TcMType
31 import TcType
32 import BuildTyCl
33 import Inst
34 import InstEnv
35 import FamInst
36 import FamInstEnv
37 import TcDeriv
38 import TcEnv
39 import TcHsType
40 import TcUnify
41 import Coercion   ( pprCoAxiom )
42 import MkCore     ( nO_METHOD_BINDING_ERROR_ID )
43 import Type
44 import TcEvidence
45 import TyCon
46 import CoAxiom
47 import DataCon
48 import Class
49 import Var
50 import VarEnv
51 import VarSet 
52 import CoreUnfold ( mkDFunUnfolding )
53 import CoreSyn    ( Expr(Var, Type), CoreExpr, mkTyApps, mkVarApps )
54 import PrelNames  ( tYPEABLE_INTERNAL, typeableClassName, oldTypeableClassNames )
55
56 import Bag
57 import BasicTypes
58 import DynFlags
59 import ErrUtils
60 import FastString
61 import HscTypes ( isHsBoot )
62 import Id
63 import MkId
64 import Name
65 import NameSet
66 import Outputable
67 import SrcLoc
68 import Util
69 import BooleanFormula ( isUnsatisfied, pprBooleanFormulaNice )
70
71 import Control.Monad
72 import Maybes     ( isNothing, isJust, whenIsJust )
73 import Data.List  ( mapAccumL )
74 \end{code}
75
76 Typechecking instance declarations is done in two passes. The first
77 pass, made by @tcInstDecls1@, collects information to be used in the
78 second pass.
79
80 This pre-processed info includes the as-yet-unprocessed bindings
81 inside the instance declaration.  These are type-checked in the second
82 pass, when the class-instance envs and GVE contain all the info from
83 all the instance and value decls.  Indeed that's the reason we need
84 two passes over the instance decls.
85
86
87 Note [How instance declarations are translated]
88 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
89 Here is how we translation instance declarations into Core
90
91 Running example:
92         class C a where
93            op1, op2 :: Ix b => a -> b -> b
94            op2 = <dm-rhs>
95
96         instance C a => C [a]
97            {-# INLINE [2] op1 #-}
98            op1 = <rhs>
99 ===>
100         -- Method selectors
101         op1,op2 :: forall a. C a => forall b. Ix b => a -> b -> b
102         op1 = ...
103         op2 = ...
104
105         -- Default methods get the 'self' dictionary as argument
106         -- so they can call other methods at the same type
107         -- Default methods get the same type as their method selector
108         $dmop2 :: forall a. C a => forall b. Ix b => a -> b -> b
109         $dmop2 = /\a. \(d:C a). /\b. \(d2: Ix b). <dm-rhs>
110                -- NB: type variables 'a' and 'b' are *both* in scope in <dm-rhs>
111                -- Note [Tricky type variable scoping]
112
113         -- A top-level definition for each instance method
114         -- Here op1_i, op2_i are the "instance method Ids"
115         -- The INLINE pragma comes from the user pragma
116         {-# INLINE [2] op1_i #-}  -- From the instance decl bindings
117         op1_i, op2_i :: forall a. C a => forall b. Ix b => [a] -> b -> b
118         op1_i = /\a. \(d:C a).
119                let this :: C [a]
120                    this = df_i a d
121                      -- Note [Subtle interaction of recursion and overlap]
122
123                    local_op1 :: forall b. Ix b => [a] -> b -> b
124                    local_op1 = <rhs>
125                      -- Source code; run the type checker on this
126                      -- NB: Type variable 'a' (but not 'b') is in scope in <rhs>
127                      -- Note [Tricky type variable scoping]
128
129                in local_op1 a d
130
131         op2_i = /\a \d:C a. $dmop2 [a] (df_i a d)
132
133         -- The dictionary function itself
134         {-# NOINLINE CONLIKE df_i #-}   -- Never inline dictionary functions
135         df_i :: forall a. C a -> C [a]
136         df_i = /\a. \d:C a. MkC (op1_i a d) (op2_i a d)
137                 -- But see Note [Default methods in instances]
138                 -- We can't apply the type checker to the default-method call
139
140         -- Use a RULE to short-circuit applications of the class ops
141         {-# RULE "op1@C[a]" forall a, d:C a.
142                             op1 [a] (df_i d) = op1_i a d #-}
143
144 Note [Instances and loop breakers]
145 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
146 * Note that df_i may be mutually recursive with both op1_i and op2_i.
147   It's crucial that df_i is not chosen as the loop breaker, even
148   though op1_i has a (user-specified) INLINE pragma.
149
150 * Instead the idea is to inline df_i into op1_i, which may then select
151   methods from the MkC record, and thereby break the recursion with
152   df_i, leaving a *self*-recurisve op1_i.  (If op1_i doesn't call op at
153   the same type, it won't mention df_i, so there won't be recursion in
154   the first place.)
155
156 * If op1_i is marked INLINE by the user there's a danger that we won't
157   inline df_i in it, and that in turn means that (since it'll be a
158   loop-breaker because df_i isn't), op1_i will ironically never be
159   inlined.  But this is OK: the recursion breaking happens by way of
160   a RULE (the magic ClassOp rule above), and RULES work inside InlineRule
161   unfoldings. See Note [RULEs enabled in SimplGently] in SimplUtils
162
163 Note [ClassOp/DFun selection]
164 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
165 One thing we see a lot is stuff like
166     op2 (df d1 d2)
167 where 'op2' is a ClassOp and 'df' is DFun.  Now, we could inline *both*
168 'op2' and 'df' to get
169      case (MkD ($cop1 d1 d2) ($cop2 d1 d2) ... of
170        MkD _ op2 _ _ _ -> op2
171 And that will reduce to ($cop2 d1 d2) which is what we wanted.
172
173 But it's tricky to make this work in practice, because it requires us to
174 inline both 'op2' and 'df'.  But neither is keen to inline without having
175 seen the other's result; and it's very easy to get code bloat (from the
176 big intermediate) if you inline a bit too much.
177
178 Instead we use a cunning trick.
179  * We arrange that 'df' and 'op2' NEVER inline.
180
181  * We arrange that 'df' is ALWAYS defined in the sylised form
182       df d1 d2 = MkD ($cop1 d1 d2) ($cop2 d1 d2) ...
183
184  * We give 'df' a magical unfolding (DFunUnfolding [$cop1, $cop2, ..])
185    that lists its methods.
186
187  * We make CoreUnfold.exprIsConApp_maybe spot a DFunUnfolding and return
188    a suitable constructor application -- inlining df "on the fly" as it
189    were.
190
191  * ClassOp rules: We give the ClassOp 'op2' a BuiltinRule that
192    extracts the right piece iff its argument satisfies
193    exprIsConApp_maybe.  This is done in MkId mkDictSelId
194
195  * We make 'df' CONLIKE, so that shared uses still match; eg
196       let d = df d1 d2
197       in ...(op2 d)...(op1 d)...
198
199 Note [Single-method classes]
200 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
201 If the class has just one method (or, more accurately, just one element
202 of {superclasses + methods}), then we use a different strategy.
203
204    class C a where op :: a -> a
205    instance C a => C [a] where op = <blah>
206
207 We translate the class decl into a newtype, which just gives a
208 top-level axiom. The "constructor" MkC expands to a cast, as does the
209 class-op selector.
210
211    axiom Co:C a :: C a ~ (a->a)
212
213    op :: forall a. C a -> (a -> a)
214    op a d = d |> (Co:C a)
215
216    MkC :: forall a. (a->a) -> C a
217    MkC = /\a.\op. op |> (sym Co:C a)
218
219 The clever RULE stuff doesn't work now, because ($df a d) isn't
220 a constructor application, so exprIsConApp_maybe won't return
221 Just <blah>.
222
223 Instead, we simply rely on the fact that casts are cheap:
224
225    $df :: forall a. C a => C [a]
226    {-# INLINE df #-}  -- NB: INLINE this
227    $df = /\a. \d. MkC [a] ($cop_list a d)
228        = $cop_list |> forall a. C a -> (sym (Co:C [a]))
229
230    $cop_list :: forall a. C a => [a] -> [a]
231    $cop_list = <blah>
232
233 So if we see
234    (op ($df a d))
235 we'll inline 'op' and '$df', since both are simply casts, and
236 good things happen.
237
238 Why do we use this different strategy?  Because otherwise we
239 end up with non-inlined dictionaries that look like
240     $df = $cop |> blah
241 which adds an extra indirection to every use, which seems stupid.  See
242 Trac #4138 for an example (although the regression reported there
243 wasn't due to the indirection).
244
245 There is an awkward wrinkle though: we want to be very
246 careful when we have
247     instance C a => C [a] where
248       {-# INLINE op #-}
249       op = ...
250 then we'll get an INLINE pragma on $cop_list but it's important that
251 $cop_list only inlines when it's applied to *two* arguments (the
252 dictionary and the list argument).  So we must not eta-expand $df
253 above.  We ensure that this doesn't happen by putting an INLINE
254 pragma on the dfun itself; after all, it ends up being just a cast.
255
256 There is one more dark corner to the INLINE story, even more deeply
257 buried.  Consider this (Trac #3772):
258
259     class DeepSeq a => C a where
260       gen :: Int -> a
261
262     instance C a => C [a] where
263       gen n = ...
264
265     class DeepSeq a where
266       deepSeq :: a -> b -> b
267
268     instance DeepSeq a => DeepSeq [a] where
269       {-# INLINE deepSeq #-}
270       deepSeq xs b = foldr deepSeq b xs
271
272 That gives rise to these defns:
273
274     $cdeepSeq :: DeepSeq a -> [a] -> b -> b
275     -- User INLINE( 3 args )!
276     $cdeepSeq a (d:DS a) b (x:[a]) (y:b) = ...
277
278     $fDeepSeq[] :: DeepSeq a -> DeepSeq [a]
279     -- DFun (with auto INLINE pragma)
280     $fDeepSeq[] a d = $cdeepSeq a d |> blah
281
282     $cp1 a d :: C a => DeepSep [a]
283     -- We don't want to eta-expand this, lest
284     -- $cdeepSeq gets inlined in it!
285     $cp1 a d = $fDeepSep[] a (scsel a d)
286
287     $fC[] :: C a => C [a]
288     -- Ordinary DFun
289     $fC[] a d = MkC ($cp1 a d) ($cgen a d)
290
291 Here $cp1 is the code that generates the superclass for C [a].  The
292 issue is this: we must not eta-expand $cp1 either, or else $fDeepSeq[]
293 and then $cdeepSeq will inline there, which is definitely wrong.  Like
294 on the dfun, we solve this by adding an INLINE pragma to $cp1.
295
296 Note [Subtle interaction of recursion and overlap]
297 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
298 Consider this
299   class C a where { op1,op2 :: a -> a }
300   instance C a => C [a] where
301     op1 x = op2 x ++ op2 x
302     op2 x = ...
303   instance C [Int] where
304     ...
305
306 When type-checking the C [a] instance, we need a C [a] dictionary (for
307 the call of op2).  If we look up in the instance environment, we find
308 an overlap.  And in *general* the right thing is to complain (see Note
309 [Overlapping instances] in InstEnv).  But in *this* case it's wrong to
310 complain, because we just want to delegate to the op2 of this same
311 instance.
312
313 Why is this justified?  Because we generate a (C [a]) constraint in
314 a context in which 'a' cannot be instantiated to anything that matches
315 other overlapping instances, or else we would not be executing this
316 version of op1 in the first place.
317
318 It might even be a bit disguised:
319
320   nullFail :: C [a] => [a] -> [a]
321   nullFail x = op2 x ++ op2 x
322
323   instance C a => C [a] where
324     op1 x = nullFail x
325
326 Precisely this is used in package 'regex-base', module Context.hs.
327 See the overlapping instances for RegexContext, and the fact that they
328 call 'nullFail' just like the example above.  The DoCon package also
329 does the same thing; it shows up in module Fraction.hs.
330
331 Conclusion: when typechecking the methods in a C [a] instance, we want to
332 treat the 'a' as an *existential* type variable, in the sense described
333 by Note [Binding when looking up instances].  That is why isOverlappableTyVar
334 responds True to an InstSkol, which is the kind of skolem we use in
335 tcInstDecl2.
336
337
338 Note [Tricky type variable scoping]
339 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
340 In our example
341         class C a where
342            op1, op2 :: Ix b => a -> b -> b
343            op2 = <dm-rhs>
344
345         instance C a => C [a]
346            {-# INLINE [2] op1 #-}
347            op1 = <rhs>
348
349 note that 'a' and 'b' are *both* in scope in <dm-rhs>, but only 'a' is
350 in scope in <rhs>.  In particular, we must make sure that 'b' is in
351 scope when typechecking <dm-rhs>.  This is achieved by subFunTys,
352 which brings appropriate tyvars into scope. This happens for both
353 <dm-rhs> and for <rhs>, but that doesn't matter: the *renamer* will have
354 complained if 'b' is mentioned in <rhs>.
355
356
357
358 %************************************************************************
359 %*                                                                      *
360 \subsection{Extracting instance decls}
361 %*                                                                      *
362 %************************************************************************
363
364 Gather up the instance declarations from their various sources
365
366 \begin{code}
367 tcInstDecls1    -- Deal with both source-code and imported instance decls
368    :: [LTyClDecl Name]          -- For deriving stuff
369    -> [LInstDecl Name]          -- Source code instance decls
370    -> [LDerivDecl Name]         -- Source code stand-alone deriving decls
371    -> TcM (TcGblEnv,            -- The full inst env
372            [InstInfo Name],     -- Source-code instance decls to process;
373                                 -- contains all dfuns for this module
374            HsValBinds Name)     -- Supporting bindings for derived instances
375
376 tcInstDecls1 tycl_decls inst_decls deriv_decls 
377   = checkNoErrs $
378     do {    -- Stop if addInstInfos etc discovers any errors
379             -- (they recover, so that we get more than one error each
380             -- round)
381
382             -- Do class and family instance declarations
383        ; env <- getGblEnv
384        ; stuff <- mapAndRecoverM tcLocalInstDecl inst_decls
385        ; let (local_infos_s, fam_insts_s) = unzip stuff
386              fam_insts    = concat fam_insts_s
387              local_infos' = concat local_infos_s
388              -- Handwritten instances of the poly-kinded Typeable class are
389              -- forbidden, so we handle those separately
390              (typeable_instances, local_infos) = splitTypeable env local_infos'
391
392        ; addClsInsts local_infos $
393          addFamInsts fam_insts   $
394     do {    -- Compute instances from "deriving" clauses;
395             -- This stuff computes a context for the derived instance
396             -- decl, so it needs to know about all the instances possible
397             -- NB: class instance declarations can contain derivings as
398             --     part of associated data type declarations
399          failIfErrsM    -- If the addInsts stuff gave any errors, don't
400                         -- try the deriving stuff, because that may give
401                         -- more errors still
402
403        ; traceTc "tcDeriving" empty
404        ; th_stage <- getStage   -- See Note [Deriving inside TH brackets ]
405        ; (gbl_env, deriv_inst_info, deriv_binds)
406               <- if isBrackStage th_stage 
407                  then do { gbl_env <- getGblEnv
408                          ; return (gbl_env, emptyBag, emptyValBindsOut) }
409                  else tcDeriving tycl_decls inst_decls deriv_decls
410
411        -- Fail if there are any handwritten instance of poly-kinded Typeable
412        ; mapM_ (failWithTc . instMsg) typeable_instances
413
414        -- Check that if the module is compiled with -XSafe, there are no
415        -- hand written instances of old Typeable as then unsafe casts could be
416        -- performed. Derived instances are OK.
417        ; dflags <- getDynFlags
418        ; when (safeLanguageOn dflags) $
419              mapM_ (\x -> when (typInstCheck x)
420                                (addErrAt (getSrcSpan $ iSpec x) typInstErr))
421                    local_infos
422        -- As above but for Safe Inference mode.
423        ; when (safeInferOn dflags) $
424              mapM_ (\x -> when (typInstCheck x) recordUnsafeInfer) local_infos
425
426        ; return ( gbl_env
427                 , bagToList deriv_inst_info ++ local_infos
428                 , deriv_binds)
429     }}
430   where
431     -- Separate the Typeable instances from the rest
432     splitTypeable _   []     = ([],[])
433     splitTypeable env (i:is) =
434       let (typeableInsts, otherInsts) = splitTypeable env is
435       in if -- We will filter out instances of Typeable
436             (typeableClassName == is_cls_nm (iSpec i))
437             -- but not those that come from Data.Typeable.Internal
438             && tcg_mod env /= tYPEABLE_INTERNAL
439             -- nor those from an .hs-boot file (deriving can't be used there)
440             && not (isHsBoot (tcg_src env))
441          then (i:typeableInsts, otherInsts)
442          else (typeableInsts, i:otherInsts)
443
444     typInstCheck ty = is_cls_nm (iSpec ty) `elem` oldTypeableClassNames
445     typInstErr = ptext $ sLit $ "Can't create hand written instances of Typeable in Safe"
446                               ++ " Haskell! Can only derive them"
447
448     instMsg i = hang (ptext (sLit $ "Typeable instances can only be derived; replace "
449                                  ++ "the following instance:"))
450                      2 (pprInstance (iSpec i))
451
452 addClsInsts :: [InstInfo Name] -> TcM a -> TcM a
453 addClsInsts infos thing_inside
454   = tcExtendLocalInstEnv (map iSpec infos) thing_inside
455
456 addFamInsts :: [FamInst] -> TcM a -> TcM a
457 -- Extend (a) the family instance envt
458 --        (b) the type envt with stuff from data type decls
459 addFamInsts fam_insts thing_inside
460   = tcExtendLocalFamInstEnv fam_insts $ 
461     tcExtendGlobalEnv things  $ 
462     do { traceTc "addFamInsts" (pprFamInsts fam_insts)
463        ; tcg_env <- tcAddImplicits things
464        ; setGblEnv tcg_env thing_inside }
465   where
466     axioms = map (toBranchedAxiom . famInstAxiom) fam_insts
467     tycons = famInstsRepTyCons fam_insts
468     things = map ATyCon tycons ++ map ACoAxiom axioms 
469 \end{code}
470
471 Note [Deriving inside TH brackets]
472 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
473 Given a declaration bracket
474   [d| data T = A | B deriving( Show ) |]
475
476 there is really no point in generating the derived code for deriving(
477 Show) and then type-checking it. This will happen at the call site
478 anyway, and the type check should never fail!  Moreover (Trac #6005)
479 the scoping of the generated code inside the bracket does not seem to 
480 work out.  
481
482 The easy solution is simply not to generate the derived instances at
483 all.  (A less brutal solution would be to generate them with no
484 bindings.)  This will become moot when we shift to the new TH plan, so 
485 the brutal solution will do.
486
487
488 \begin{code}
489 tcLocalInstDecl :: LInstDecl Name
490                 -> TcM ([InstInfo Name], [FamInst])
491         -- A source-file instance declaration
492         -- Type-check all the stuff before the "where"
493         --
494         -- We check for respectable instance type, and context
495 tcLocalInstDecl (L loc (TyFamInstD { tfid_inst = decl }))
496   = do { fam_inst <- tcTyFamInstDecl Nothing (L loc decl)
497        ; return ([], [fam_inst]) }
498
499 tcLocalInstDecl (L loc (DataFamInstD { dfid_inst = decl }))
500   = do { fam_inst <- tcDataFamInstDecl Nothing (L loc decl)
501        ; return ([], [fam_inst]) }
502
503 tcLocalInstDecl (L loc (ClsInstD { cid_inst = decl }))
504   = do { (insts, fam_insts) <- tcClsInstDecl (L loc decl)
505        ; return (insts, fam_insts) }
506
507 tcClsInstDecl :: LClsInstDecl Name -> TcM ([InstInfo Name], [FamInst])
508 tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds
509                                   , cid_sigs = uprags, cid_tyfam_insts = ats
510                                   , cid_overlap_mode = overlap_mode
511                                   , cid_datafam_insts = adts }))
512   = setSrcSpan loc                      $
513     addErrCtxt (instDeclCtxt1 poly_ty)  $
514     do  { is_boot <- tcIsHsBoot
515         ; checkTc (not is_boot || (isEmptyLHsBinds binds && null uprags))
516                   badBootDeclErr
517
518         ; (tyvars, theta, clas, inst_tys) <- tcHsInstHead InstDeclCtxt poly_ty
519         ; let mini_env   = mkVarEnv (classTyVars clas `zip` inst_tys)
520               mini_subst = mkTvSubst (mkInScopeSet (mkVarSet tyvars)) mini_env
521               mb_info    = Just (clas, mini_env)
522                            
523         -- Next, process any associated types.
524         ; traceTc "tcLocalInstDecl" (ppr poly_ty)
525         ; tyfam_insts0 <- tcExtendTyVarEnv tyvars $
526                           mapAndRecoverM (tcAssocTyDecl clas mini_env) ats
527         ; datafam_insts <- tcExtendTyVarEnv tyvars $
528                            mapAndRecoverM (tcDataFamInstDecl mb_info) adts
529
530         -- Check for missing associated types and build them
531         -- from their defaults (if available)
532         ; let defined_ats = mkNameSet (map (tyFamInstDeclName . unLoc) ats)
533                             `unionNameSets` 
534                             mkNameSet (map (unLoc . dfid_tycon . unLoc) adts)
535         ; tyfam_insts1 <- mapM (tcATDefault mini_subst defined_ats) 
536                                (classATItems clas)
537         
538         -- Finally, construct the Core representation of the instance.
539         -- (This no longer includes the associated types.)
540         ; dfun_name <- newDFunName clas inst_tys (getLoc poly_ty)
541                 -- Dfun location is that of instance *header*
542
543         ; overlap_flag <-
544             do defaultOverlapFlag <- getOverlapFlag
545                return $ setOverlapModeMaybe defaultOverlapFlag overlap_mode
546         ; (subst, tyvars') <- tcInstSkolTyVars tyvars
547         ; let dfun      = mkDictFunId dfun_name tyvars theta clas inst_tys
548               ispec     = mkLocalInstance dfun overlap_flag tyvars' clas (substTys subst inst_tys)
549                             -- Be sure to freshen those type variables, 
550                             -- so they are sure not to appear in any lookup
551               inst_info = InstInfo { iSpec  = ispec
552                                    , iBinds = InstBindings
553                                      { ib_binds = binds
554                                      , ib_pragmas = uprags
555                                      , ib_extensions = []
556                                      , ib_standalone_deriving = False } }
557
558         ; return ( [inst_info], tyfam_insts0 ++ concat tyfam_insts1 ++ datafam_insts) }
559
560
561 tcATDefault :: TvSubst -> NameSet -> ClassATItem -> TcM [FamInst]
562 -- ^ Construct default instances for any associated types that
563 -- aren't given a user definition
564 -- Returns [] or singleton
565 tcATDefault inst_subst defined_ats (ATI fam_tc defs)
566   -- User supplied instances ==> everything is OK
567   | tyConName fam_tc `elemNameSet` defined_ats
568   = return []
569
570   -- No user instance, have defaults ==> instatiate them
571    -- Example:   class C a where { type F a b :: *; type F a b = () }
572    --            instance C [x]
573    -- Then we want to generate the decl:   type F [x] b = ()
574   | Just rhs_ty <- defs
575   = do { let (subst', pat_tys') = mapAccumL subst_tv inst_subst
576                                             (tyConTyVars fam_tc)
577              rhs'     = substTy subst' rhs_ty
578              tv_set'  = tyVarsOfTypes pat_tys'
579              tvs'     = varSetElemsKvsFirst tv_set'
580        ; rep_tc_name <- newFamInstTyConName (noLoc (tyConName fam_tc)) pat_tys'
581        ; let axiom = mkSingleCoAxiom rep_tc_name tvs' fam_tc pat_tys' rhs'
582        ; traceTc "mk_deflt_at_instance" (vcat [ ppr fam_tc, ppr rhs_ty
583                                               , pprCoAxiom axiom ])
584        ; fam_inst <- ASSERT( tyVarsOfType rhs' `subVarSet` tv_set' ) 
585                      newFamInst SynFamilyInst axiom
586        ; return [fam_inst] }
587
588    -- No defaults ==> generate a warning
589   | otherwise  -- defs = Nothing
590   = do { warnMissingMethodOrAT "associated type" (tyConName fam_tc)
591        ; return [] }
592   where
593     subst_tv subst tc_tv 
594       | Just ty <- lookupVarEnv (getTvSubstEnv subst) tc_tv
595       = (subst, ty)
596       | otherwise
597       = (extendTvSubst subst tc_tv ty', ty')
598       where
599         ty' = mkTyVarTy (updateTyVarKind (substTy subst) tc_tv)
600                            
601
602 --------------
603 tcAssocTyDecl :: Class                   -- Class of associated type
604               -> VarEnv Type             -- Instantiation of class TyVars
605               -> LTyFamInstDecl Name     
606               -> TcM (FamInst)
607 tcAssocTyDecl clas mini_env ldecl
608   = do { fam_inst <- tcTyFamInstDecl (Just (clas, mini_env)) ldecl
609        ; return fam_inst }
610 \end{code}
611
612 %************************************************************************
613 %*                                                                      *
614                Type checking family instances
615 %*                                                                      *
616 %************************************************************************
617
618 Family instances are somewhat of a hybrid.  They are processed together with
619 class instance heads, but can contain data constructors and hence they share a
620 lot of kinding and type checking code with ordinary algebraic data types (and
621 GADTs).
622
623 \begin{code}
624 tcFamInstDeclCombined :: Maybe (Class, VarEnv Type) -- the class & mini_env if applicable
625                       -> Located Name -> TcM TyCon
626 tcFamInstDeclCombined mb_clsinfo fam_tc_lname
627   = do { -- Type family instances require -XTypeFamilies
628          -- and can't (currently) be in an hs-boot file
629        ; traceTc "tcFamInstDecl" (ppr fam_tc_lname)
630        ; type_families <- xoptM Opt_TypeFamilies
631        ; is_boot <- tcIsHsBoot   -- Are we compiling an hs-boot file?
632        ; checkTc type_families $ badFamInstDecl fam_tc_lname
633        ; checkTc (not is_boot) $ badBootFamInstDeclErr
634
635        -- Look up the family TyCon and check for validity including
636        -- check that toplevel type instances are not for associated types.
637        ; fam_tc <- tcLookupLocatedTyCon fam_tc_lname
638        ; when (isNothing mb_clsinfo &&   -- Not in a class decl
639                isTyConAssoc fam_tc)      -- but an associated type
640               (addErr $ assocInClassErr fam_tc_lname)
641
642        ; return fam_tc }
643
644 tcTyFamInstDecl :: Maybe (Class, VarEnv Type) -- the class & mini_env if applicable
645                 -> LTyFamInstDecl Name -> TcM FamInst
646   -- "type instance"
647 tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn }))
648   = setSrcSpan loc           $
649     tcAddTyFamInstCtxt decl  $
650     do { let fam_lname = tfe_tycon (unLoc eqn)
651        ; fam_tc <- tcFamInstDeclCombined mb_clsinfo fam_lname
652
653          -- (0) Check it's an open type family
654        ; checkTc (isFamilyTyCon fam_tc)        (notFamily fam_tc)
655        ; checkTc (isSynFamilyTyCon fam_tc)     (wrongKindOfFamily fam_tc)
656        ; checkTc (isOpenSynFamilyTyCon fam_tc) (notOpenFamily fam_tc)
657
658          -- (1) do the work of verifying the synonym group
659        ; co_ax_branch <- tcTyFamInstEqn (famTyConShape fam_tc) eqn
660
661          -- (2) check for validity
662        ; checkValidTyFamInst mb_clsinfo fam_tc co_ax_branch
663
664          -- (3) construct coercion axiom
665        ; rep_tc_name <- newFamInstAxiomName loc (unLoc fam_lname)
666                                             [co_ax_branch]
667        ; let axiom = mkUnbranchedCoAxiom rep_tc_name fam_tc co_ax_branch
668        ; newFamInst SynFamilyInst axiom }
669
670 tcDataFamInstDecl :: Maybe (Class, VarEnv Type)
671                   -> LDataFamInstDecl Name -> TcM FamInst
672   -- "newtype instance" and "data instance"
673 tcDataFamInstDecl mb_clsinfo 
674     (L loc decl@(DataFamInstDecl
675        { dfid_pats = pats
676        , dfid_tycon = fam_tc_name
677        , dfid_defn = defn@HsDataDefn { dd_ND = new_or_data, dd_cType = cType
678                                      , dd_ctxt = ctxt, dd_cons = cons } }))
679   = setSrcSpan loc             $
680     tcAddDataFamInstCtxt decl  $
681     do { fam_tc <- tcFamInstDeclCombined mb_clsinfo fam_tc_name
682
683          -- Check that the family declaration is for the right kind
684        ; checkTc (isFamilyTyCon fam_tc) (notFamily fam_tc)
685        ; checkTc (isAlgTyCon fam_tc) (wrongKindOfFamily fam_tc)
686
687          -- Kind check type patterns
688        ; tcFamTyPats (famTyConShape fam_tc) pats
689                      (kcDataDefn defn) $ 
690            \tvs' pats' res_kind -> do
691
692        { -- Check that left-hand side contains no type family applications
693          -- (vanilla synonyms are fine, though, and we checked for
694          --  foralls earlier)
695          checkValidFamPats fam_tc tvs' pats'
696          -- Check that type patterns match class instance head, if any
697        ; checkConsistentFamInst mb_clsinfo fam_tc tvs' pats'
698          
699          -- Result kind must be '*' (otherwise, we have too few patterns)
700        ; checkTc (isLiftedTypeKind res_kind) $ tooFewParmsErr (tyConArity fam_tc)
701
702        ; stupid_theta <- tcHsContext ctxt
703        ; gadt_syntax <- dataDeclChecks (tyConName fam_tc) new_or_data stupid_theta cons
704
705          -- Construct representation tycon
706        ; rep_tc_name <- newFamInstTyConName fam_tc_name pats'
707        ; axiom_name  <- newImplicitBinder rep_tc_name mkInstTyCoOcc
708        ; let orig_res_ty = mkTyConApp fam_tc pats'
709
710        ; (rep_tc, fam_inst) <- fixM $ \ ~(rec_rep_tc, _) ->
711            do { data_cons <- tcConDecls new_or_data rec_rep_tc
712                                        (tvs', orig_res_ty) cons
713               ; tc_rhs <- case new_or_data of
714                      DataType -> return (mkDataTyConRhs data_cons)
715                      NewType  -> ASSERT( not (null data_cons) )
716                                  mkNewTyConRhs rep_tc_name rec_rep_tc (head data_cons)
717               -- freshen tyvars
718               ; let (eta_tvs, eta_pats) = eta_reduce tvs' pats'
719                     axiom    = mkSingleCoAxiom axiom_name eta_tvs fam_tc eta_pats 
720                                                (mkTyConApp rep_tc (mkTyVarTys eta_tvs))
721                     parent   = FamInstTyCon axiom fam_tc pats'
722                     roles    = map (const Nominal) tvs'
723                     rep_tc   = buildAlgTyCon rep_tc_name tvs' roles cType stupid_theta tc_rhs 
724                                              Recursive 
725                                              False      -- No promotable to the kind level
726                                              gadt_syntax parent
727                  -- We always assume that indexed types are recursive.  Why?
728                  -- (1) Due to their open nature, we can never be sure that a
729                  -- further instance might not introduce a new recursive
730                  -- dependency.  (2) They are always valid loop breakers as
731                  -- they involve a coercion.
732               ; fam_inst <- newFamInst (DataFamilyInst rep_tc) axiom
733               ; return (rep_tc, fam_inst) }
734
735          -- Remember to check validity; no recursion to worry about here
736        ; checkValidTyCon rep_tc
737        ; return fam_inst } }
738   where
739     -- See Note [Eta reduction for data family axioms]
740     --  [a,b,c,d].T [a] c Int c d  ==>  [a,b,c]. T [a] c Int c
741     eta_reduce tvs pats = go (reverse tvs) (reverse pats)
742     go (tv:tvs) (pat:pats)
743       | Just tv' <- getTyVar_maybe pat
744       , tv == tv'
745       , not (tv `elemVarSet` tyVarsOfTypes pats)
746       = go tvs pats
747     go tvs pats = (reverse tvs, reverse pats)
748
749 \end{code}
750
751 Note [Eta reduction for data family axioms]
752 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
753 Consider this
754    data family T a b :: *
755    newtype instance T Int a = MkT (IO a) deriving( Monad )
756 We'd like this to work.  From the 'newtype instance' you might
757 think we'd get:
758    newtype TInt a = MkT (IO a)
759    axiom ax1 a :: T Int a ~ TInt a   -- The type-instance part
760    axiom ax2 a :: TInt a ~ IO a      -- The newtype part
761
762 But now what can we do?  We have this problem
763    Given:   d  :: Monad IO
764    Wanted:  d' :: Monad (T Int) = d |> ????
765 What coercion can we use for the ???
766
767 Solution: eta-reduce both axioms, thus:
768    axiom ax1 :: T Int ~ TInt
769    axiom ax2 :: TInt ~ IO
770 Now
771    d' = d |> Monad (sym (ax2 ; ax1))
772
773 This eta reduction happens both for data instances and newtype instances.
774
775 See Note [Newtype eta] in TyCon.
776
777
778
779 %************************************************************************
780 %*                                                                      *
781       Type-checking instance declarations, pass 2
782 %*                                                                      *
783 %************************************************************************
784
785 \begin{code}
786 tcInstDecls2 :: [LTyClDecl Name] -> [InstInfo Name]
787              -> TcM (LHsBinds Id)
788 -- (a) From each class declaration,
789 --      generate any default-method bindings
790 -- (b) From each instance decl
791 --      generate the dfun binding
792
793 tcInstDecls2 tycl_decls inst_decls
794   = do  { -- (a) Default methods from class decls
795           let class_decls = filter (isClassDecl . unLoc) tycl_decls
796         ; dm_binds_s <- mapM tcClassDecl2 class_decls
797         ; let dm_binds = unionManyBags dm_binds_s
798
799           -- (b) instance declarations
800         ; let dm_ids = collectHsBindsBinders dm_binds
801               -- Add the default method Ids (again)
802               -- See Note [Default methods and instances]
803         ; inst_binds_s <- tcExtendLetEnv TopLevel TopLevel dm_ids $
804                           mapM tcInstDecl2 inst_decls
805
806           -- Done
807         ; return (dm_binds `unionBags` unionManyBags inst_binds_s) }
808 \end{code}
809
810 See Note [Default methods and instances]
811 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
812 The default method Ids are already in the type environment (see Note
813 [Default method Ids and Template Haskell] in TcTyClsDcls), BUT they
814 don't have their InlinePragmas yet.  Usually that would not matter,
815 because the simplifier propagates information from binding site to
816 use.  But, unusually, when compiling instance decls we *copy* the
817 INLINE pragma from the default method to the method for that
818 particular operation (see Note [INLINE and default methods] below).
819
820 So right here in tcInstDecls2 we must re-extend the type envt with
821 the default method Ids replete with their INLINE pragmas.  Urk.
822
823 \begin{code}
824
825 tcInstDecl2 :: InstInfo Name -> TcM (LHsBinds Id)
826             -- Returns a binding for the dfun
827 tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
828   = recoverM (return emptyLHsBinds)             $
829     setSrcSpan loc                              $
830     addErrCtxt (instDeclCtxt2 (idType dfun_id)) $
831     do {  -- Instantiate the instance decl with skolem constants
832        ; (inst_tyvars, dfun_theta, inst_head) <- tcSkolDFunType (idType dfun_id)
833                      -- We instantiate the dfun_id with superSkolems.
834                      -- See Note [Subtle interaction of recursion and overlap]
835                      -- and Note [Binding when looking up instances]
836        ; let (clas, inst_tys) = tcSplitDFunHead inst_head
837              (class_tyvars, sc_theta, _, op_items) = classBigSig clas
838              sc_theta' = substTheta (zipOpenTvSubst class_tyvars inst_tys) sc_theta
839
840        ; dfun_ev_vars <- newEvVars dfun_theta
841
842        ; (sc_binds, sc_ev_vars) <- tcSuperClasses dfun_id inst_tyvars dfun_ev_vars sc_theta'
843
844        -- Deal with 'SPECIALISE instance' pragmas
845        -- See Note [SPECIALISE instance pragmas]
846        ; spec_inst_info@(spec_inst_prags,_) <- tcSpecInstPrags dfun_id ibinds
847
848         -- Typecheck the methods
849        ; (meth_ids, meth_binds)
850            <- tcExtendTyVarEnv inst_tyvars $
851                 -- The inst_tyvars scope over the 'where' part
852                 -- Those tyvars are inside the dfun_id's type, which is a bit
853                 -- bizarre, but OK so long as you realise it!
854               tcInstanceMethods dfun_id clas inst_tyvars dfun_ev_vars
855                                 inst_tys spec_inst_info
856                                 op_items ibinds
857
858        -- Create the result bindings
859        ; self_dict <- newDict clas inst_tys
860        ; let class_tc      = classTyCon clas
861              [dict_constr] = tyConDataCons class_tc
862              dict_bind     = mkVarBind self_dict (L loc con_app_args)
863
864                      -- We don't produce a binding for the dict_constr; instead we
865                      -- rely on the simplifier to unfold this saturated application
866                      -- We do this rather than generate an HsCon directly, because
867                      -- it means that the special cases (e.g. dictionary with only one
868                      -- member) are dealt with by the common MkId.mkDataConWrapId
869                      -- code rather than needing to be repeated here.
870                      --    con_app_tys  = MkD ty1 ty2
871                      --    con_app_scs  = MkD ty1 ty2 sc1 sc2
872                      --    con_app_args = MkD ty1 ty2 sc1 sc2 op1 op2
873              con_app_tys  = wrapId (mkWpTyApps inst_tys)
874                                    (dataConWrapId dict_constr)
875              con_app_scs  = mkHsWrap (mkWpEvApps (map EvId sc_ev_vars)) con_app_tys
876              con_app_args = foldl app_to_meth con_app_scs meth_ids
877
878              app_to_meth :: HsExpr Id -> Id -> HsExpr Id
879              app_to_meth fun meth_id = L loc fun `HsApp` L loc (wrapId arg_wrapper meth_id)
880
881              inst_tv_tys = mkTyVarTys inst_tyvars
882              arg_wrapper = mkWpEvVarApps dfun_ev_vars <.> mkWpTyApps inst_tv_tys
883
884                 -- Do not inline the dfun; instead give it a magic DFunFunfolding
885                 -- See Note [ClassOp/DFun selection]
886                 -- See also note [Single-method classes]
887              (dfun_id_w_fun, dfun_spec_prags)
888                 | isNewTyCon class_tc
889                 = ( dfun_id `setInlinePragma` alwaysInlinePragma { inl_sat = Just 0 }
890                   , SpecPrags [] )   -- Newtype dfuns just inline unconditionally,
891                                      -- so don't attempt to specialise them
892                 | otherwise
893                 = ( dfun_id `setIdUnfolding`  mkDFunUnfolding (inst_tyvars ++ dfun_ev_vars)
894                                                               dict_constr dfun_args
895                             `setInlinePragma` dfunInlinePragma
896                   , SpecPrags spec_inst_prags )
897
898              dfun_args :: [CoreExpr]
899              dfun_args = map Type inst_tys        ++
900                          map Var  sc_ev_vars      ++ 
901                          map mk_meth_app meth_ids
902              mk_meth_app meth_id = Var meth_id `mkTyApps` inst_tv_tys `mkVarApps` dfun_ev_vars 
903
904              export = ABE { abe_wrap = idHsWrapper, abe_poly = dfun_id_w_fun
905                           , abe_mono = self_dict, abe_prags = dfun_spec_prags }
906                           -- NB: see Note [SPECIALISE instance pragmas]
907              main_bind = AbsBinds { abs_tvs = inst_tyvars
908                                   , abs_ev_vars = dfun_ev_vars
909                                   , abs_exports = [export]
910                                   , abs_ev_binds = sc_binds
911                                   , abs_binds = unitBag dict_bind }
912
913        ; return (unitBag (L loc main_bind) `unionBags`
914                  listToBag meth_binds)
915        }
916  where
917    dfun_id = instanceDFunId ispec
918    loc     = getSrcSpan dfun_id
919
920 ------------------------------
921 tcSuperClasses :: DFunId -> [TcTyVar] -> [EvVar] -> TcThetaType
922                -> TcM (TcEvBinds, [EvVar])
923 -- See Note [Silent superclass arguments]
924 tcSuperClasses dfun_id inst_tyvars dfun_ev_vars sc_theta
925   = do {   -- Check that all superclasses can be deduced from
926            -- the originally-specified dfun arguments
927        ; (sc_binds, sc_evs) <- checkConstraints InstSkol inst_tyvars orig_ev_vars $
928                                emitWanteds ScOrigin sc_theta
929
930        ; if null inst_tyvars && null dfun_ev_vars 
931          then return (sc_binds,       sc_evs)
932          else return (emptyTcEvBinds, sc_lam_args) }
933   where
934     n_silent     = dfunNSilent dfun_id
935     orig_ev_vars = drop n_silent dfun_ev_vars
936
937     sc_lam_args = map (find dfun_ev_vars) sc_theta
938     find [] pred 
939       = pprPanic "tcInstDecl2" (ppr dfun_id $$ ppr (idType dfun_id) $$ ppr pred)
940     find (ev:evs) pred 
941       | pred `eqPred` evVarPred ev = ev
942       | otherwise                  = find evs pred
943
944 ----------------------
945 mkMethIds :: HsSigFun -> Class -> [TcTyVar] -> [EvVar] 
946           -> [TcType] -> Id -> TcM (TcId, TcSigInfo)
947 mkMethIds sig_fn clas tyvars dfun_ev_vars inst_tys sel_id
948   = do  { let sel_occ = nameOccName sel_name
949         ; meth_name <- newName (mkClassOpAuxOcc sel_occ)
950         ; local_meth_name <- newName sel_occ
951                   -- Base the local_meth_name on the selector name, because
952                   -- type errors from tcInstanceMethodBody come from here
953
954         ; local_meth_sig <- case lookupHsSig sig_fn sel_name of
955             Just hs_ty  -- There is a signature in the instance declaration
956                -> do { sig_ty <- check_inst_sig hs_ty
957                      ; instTcTySig hs_ty sig_ty local_meth_name }
958
959             Nothing     -- No type signature
960                -> do { loc <- getSrcSpanM
961                      ; instTcTySigFromId loc (mkLocalId local_meth_name local_meth_ty) }
962               -- Absent a type sig, there are no new scoped type variables here
963               -- Only the ones from the instance decl itself, which are already
964               -- in scope.  Example:
965               --      class C a where { op :: forall b. Eq b => ... }
966               --      instance C [c] where { op = <rhs> }
967               -- In <rhs>, 'c' is scope but 'b' is not!
968
969         ; let meth_id = mkLocalId meth_name meth_ty
970         ; return (meth_id, local_meth_sig) }
971   where
972     sel_name      = idName sel_id
973     local_meth_ty = instantiateMethod clas sel_id inst_tys
974     meth_ty       = mkForAllTys tyvars $ mkPiTypes dfun_ev_vars local_meth_ty
975
976     -- Check that any type signatures have exactly the right type
977     check_inst_sig hs_ty@(L loc _) 
978        = setSrcSpan loc $ 
979          do { sig_ty <- tcHsSigType (FunSigCtxt sel_name) hs_ty
980             ; inst_sigs <- xoptM Opt_InstanceSigs
981             ; if inst_sigs then 
982                 unless (sig_ty `eqType` local_meth_ty)
983                        (badInstSigErr sel_name local_meth_ty)
984               else
985                 addErrTc (misplacedInstSig sel_name hs_ty)
986             ; return sig_ty }
987
988 badInstSigErr :: Name -> Type -> TcM ()
989 badInstSigErr meth ty
990   = do { env0 <- tcInitTidyEnv
991        ; let tidy_ty = tidyType env0 ty
992                  -- Tidy the type using the ambient TidyEnv, 
993                  -- to avoid apparent name capture (Trac #7475)
994                  --    class C a where { op :: a -> b }
995                  --    instance C (a->b) where
996                  --       op :: forall x. x
997                  --       op = ...blah...
998        ; addErrTc (hang (ptext (sLit "Method signature does not match class; it should be"))
999                       2 (pprPrefixName meth <+> dcolon <+> ppr tidy_ty)) }
1000
1001 misplacedInstSig :: Name -> LHsType Name -> SDoc
1002 misplacedInstSig name hs_ty
1003   = vcat [ hang (ptext (sLit "Illegal type signature in instance declaration:"))
1004               2 (hang (pprPrefixName name)
1005                     2 (dcolon <+> ppr hs_ty))
1006          , ptext (sLit "(Use InstanceSigs to allow this)") ]
1007
1008 ------------------------------
1009 tcSpecInstPrags :: DFunId -> InstBindings Name
1010                 -> TcM ([Located TcSpecPrag], PragFun)
1011 tcSpecInstPrags dfun_id (InstBindings { ib_binds = binds, ib_pragmas = uprags })
1012   = do { spec_inst_prags <- mapM (wrapLocM (tcSpecInst dfun_id)) $
1013                             filter isSpecInstLSig uprags
1014              -- The filter removes the pragmas for methods
1015        ; return (spec_inst_prags, mkPragFun uprags binds) }
1016 \end{code}
1017
1018 Note [Silent superclass arguments]
1019 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1020 See Trac #3731, #4809, #5751, #5913, #6117, which all
1021 describe somewhat more complicated situations, but ones
1022 encountered in practice.  
1023
1024       THE PROBLEM
1025
1026 The problem is that it is all too easy to create a class whose
1027 superclass is bottom when it should not be.
1028
1029 Consider the following (extreme) situation:
1030         class C a => D a where ...
1031         instance D [a] => D [a] where ...
1032 Although this looks wrong (assume D [a] to prove D [a]), it is only a
1033 more extreme case of what happens with recursive dictionaries, and it
1034 can, just about, make sense because the methods do some work before
1035 recursing.
1036
1037 To implement the dfun we must generate code for the superclass C [a],
1038 which we had better not get by superclass selection from the supplied
1039 argument:
1040        dfun :: forall a. D [a] -> D [a]
1041        dfun = \d::D [a] -> MkD (scsel d) ..
1042
1043 Otherwise if we later encounter a situation where
1044 we have a [Wanted] dw::D [a] we might solve it thus:
1045      dw := dfun dw
1046 Which is all fine except that now ** the superclass C is bottom **!
1047
1048       THE SOLUTION
1049
1050 Our solution to this problem "silent superclass arguments".  We pass
1051 to each dfun some ``silent superclass arguments’’, which are the
1052 immediate superclasses of the dictionary we are trying to
1053 construct. In our example:
1054        dfun :: forall a. C [a] -> D [a] -> D [a]
1055        dfun = \(dc::C [a]) (dd::D [a]) -> DOrd dc ...
1056 Notice the extra (dc :: C [a]) argument compared to the previous version.
1057
1058 This gives us:
1059
1060      -----------------------------------------------------------
1061      DFun Superclass Invariant
1062      ~~~~~~~~~~~~~~~~~~~~~~~~
1063      In the body of a DFun, every superclass argument to the
1064      returned dictionary is
1065        either   * one of the arguments of the DFun,
1066        or       * constant, bound at top level
1067      -----------------------------------------------------------
1068
1069 This net effect is that it is safe to treat a dfun application as
1070 wrapping a dictionary constructor around its arguments (in particular,
1071 a dfun never picks superclasses from the arguments under the
1072 dictionary constructor). No superclass is hidden inside a dfun
1073 application.
1074
1075 The extra arguments required to satisfy the DFun Superclass Invariant
1076 always come first, and are called the "silent" arguments.  You can
1077 find out how many silent arguments there are using Id.dfunNSilent;
1078 and then you can just drop that number of arguments to see the ones
1079 that were in the original instance declaration.
1080
1081 DFun types are built (only) by MkId.mkDictFunId, so that is where we
1082 decide what silent arguments are to be added.
1083
1084 In our example, if we had  [Wanted] dw :: D [a] we would get via the instance:
1085     dw := dfun d1 d2
1086     [Wanted] (d1 :: C [a])
1087     [Wanted] (d2 :: D [a])
1088
1089 And now, though we *can* solve: 
1090      d2 := dw
1091 That's fine; and we solve d1:C[a] separately.
1092
1093 Test case SCLoop tests this fix.
1094
1095 Note [SPECIALISE instance pragmas]
1096 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1097 Consider
1098
1099    instance (Ix a, Ix b) => Ix (a,b) where
1100      {-# SPECIALISE instance Ix (Int,Int) #-}
1101      range (x,y) = ...
1102
1103 We make a specialised version of the dictionary function, AND
1104 specialised versions of each *method*.  Thus we should generate
1105 something like this:
1106
1107   $dfIxPair :: (Ix a, Ix b) => Ix (a,b)
1108   {-# DFUN [$crangePair, ...] #-}
1109   {-# SPECIALISE $dfIxPair :: Ix (Int,Int) #-}
1110   $dfIxPair da db = Ix ($crangePair da db) (...other methods...)
1111
1112   $crange :: (Ix a, Ix b) -> ((a,b),(a,b)) -> [(a,b)]
1113   {-# SPECIALISE $crange :: ((Int,Int),(Int,Int)) -> [(Int,Int)] #-}
1114   $crange da db = <blah>
1115
1116 The SPECIALISE pragmas are acted upon by the desugarer, which generate
1117
1118   dii :: Ix Int
1119   dii = ...
1120
1121   $s$dfIxPair :: Ix ((Int,Int),(Int,Int))
1122   {-# DFUN [$crangePair di di, ...] #-}
1123   $s$dfIxPair = Ix ($crangePair di di) (...)
1124
1125   {-# RULE forall (d1,d2:Ix Int). $dfIxPair Int Int d1 d2 = $s$dfIxPair #-}
1126
1127   $s$crangePair :: ((Int,Int),(Int,Int)) -> [(Int,Int)]
1128   $c$crangePair = ...specialised RHS of $crangePair...
1129
1130   {-# RULE forall (d1,d2:Ix Int). $crangePair Int Int d1 d2 = $s$crangePair #-}
1131  
1132 Note that
1133
1134   * The specialised dictionary $s$dfIxPair is very much needed, in case we
1135     call a function that takes a dictionary, but in a context where the 
1136     specialised dictionary can be used.  See Trac #7797.
1137
1138   * The ClassOp rule for 'range' works equally well on $s$dfIxPair, because
1139     it still has a DFunUnfolding.  See Note [ClassOp/DFun selection]
1140
1141   * A call (range ($dfIxPair Int Int d1 d2)) might simplify two ways:
1142        --> {ClassOp rule for range}     $crangePair Int Int d1 d2
1143        --> {SPEC rule for $crangePair}  $s$crangePair
1144     or thus:
1145        --> {SPEC rule for $dfIxPair}    range $s$dfIxPair
1146        --> {ClassOpRule for range}      $s$crangePair
1147     It doesn't matter which way.
1148
1149   * We want to specialise the RHS of both $dfIxPair and $crangePair,
1150     but the SAME HsWrapper will do for both!  We can call tcSpecPrag
1151     just once, and pass the result (in spec_inst_info) to tcInstanceMethods.
1152
1153
1154 \begin{code}
1155 tcSpecInst :: Id -> Sig Name -> TcM TcSpecPrag
1156 tcSpecInst dfun_id prag@(SpecInstSig hs_ty)
1157   = addErrCtxt (spec_ctxt prag) $
1158     do  { let name = idName dfun_id
1159         ; (tyvars, theta, clas, tys) <- tcHsInstHead SpecInstCtxt hs_ty
1160         ; let (_, spec_dfun_ty) = mkDictFunTy tyvars theta clas tys
1161
1162         ; co_fn <- tcSubType (SpecPragOrigin name) SpecInstCtxt
1163                              (idType dfun_id) spec_dfun_ty
1164         ; return (SpecPrag dfun_id co_fn defaultInlinePragma) }
1165   where
1166     spec_ctxt prag = hang (ptext (sLit "In the SPECIALISE pragma")) 2 (ppr prag)
1167
1168 tcSpecInst _  _ = panic "tcSpecInst"
1169 \end{code}
1170
1171 %************************************************************************
1172 %*                                                                      *
1173       Type-checking an instance method
1174 %*                                                                      *
1175 %************************************************************************
1176
1177 tcInstanceMethod
1178 - Make the method bindings, as a [(NonRec, HsBinds)], one per method
1179 - Remembering to use fresh Name (the instance method Name) as the binder
1180 - Bring the instance method Ids into scope, for the benefit of tcInstSig
1181 - Use sig_fn mapping instance method Name -> instance tyvars
1182 - Ditto prag_fn
1183 - Use tcValBinds to do the checking
1184
1185 \begin{code}
1186 tcInstanceMethods :: DFunId -> Class -> [TcTyVar]
1187                   -> [EvVar]
1188                   -> [TcType]
1189                   -> ([Located TcSpecPrag], PragFun)
1190                   -> [(Id, DefMeth)]
1191                   -> InstBindings Name
1192                   -> TcM ([Id], [LHsBind Id])
1193         -- The returned inst_meth_ids all have types starting
1194         --      forall tvs. theta => ...
1195 tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
1196                   (spec_inst_prags, prag_fn)
1197                   op_items (InstBindings { ib_binds = binds
1198                                          , ib_pragmas = sigs
1199                                          , ib_extensions = exts
1200                                          , ib_standalone_deriving
1201                                               = standalone_deriv })
1202   = do { traceTc "tcInstMeth" (ppr sigs $$ ppr binds)
1203        ; let hs_sig_fn = mkHsSigFun sigs
1204        ; checkMinimalDefinition
1205        ; set_exts exts $ mapAndUnzipM (tc_item hs_sig_fn) op_items }
1206   where
1207     set_exts :: [ExtensionFlag] -> TcM a -> TcM a
1208     set_exts es thing = foldr setXOptM thing es
1209     
1210     ----------------------
1211     tc_item :: HsSigFun -> (Id, DefMeth) -> TcM (Id, LHsBind Id)
1212     tc_item sig_fn (sel_id, dm_info)
1213       = case findMethodBind (idName sel_id) binds of
1214             Just (user_bind, bndr_loc) 
1215                      -> tc_body sig_fn sel_id standalone_deriv user_bind bndr_loc
1216             Nothing  -> do { traceTc "tc_def" (ppr sel_id)
1217                            ; tc_default sig_fn sel_id dm_info }
1218
1219     ----------------------
1220     tc_body :: HsSigFun -> Id -> Bool -> LHsBind Name
1221             -> SrcSpan -> TcM (TcId, LHsBind Id)
1222     tc_body sig_fn sel_id generated_code rn_bind bndr_loc
1223       = add_meth_ctxt sel_id generated_code rn_bind $
1224         do { traceTc "tc_item" (ppr sel_id <+> ppr (idType sel_id))
1225            ; (meth_id, local_meth_sig) <- setSrcSpan bndr_loc $
1226                                           mkMethIds sig_fn clas tyvars dfun_ev_vars
1227                                                     inst_tys sel_id
1228            ; let prags = prag_fn (idName sel_id)
1229            ; meth_id1 <- addInlinePrags meth_id prags
1230            ; spec_prags <- tcSpecPrags meth_id1 prags
1231            ; bind <- tcInstanceMethodBody InstSkol
1232                           tyvars dfun_ev_vars
1233                           meth_id1 local_meth_sig
1234                           (mk_meth_spec_prags meth_id1 spec_prags)
1235                           rn_bind
1236            ; return (meth_id1, bind) }
1237
1238     ----------------------
1239     tc_default :: HsSigFun -> Id -> DefMeth -> TcM (TcId, LHsBind Id)
1240
1241     tc_default sig_fn sel_id (GenDefMeth dm_name)
1242       = do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id dm_name
1243            ; tc_body sig_fn sel_id False {- Not generated code? -} 
1244                      meth_bind inst_loc }
1245
1246     tc_default sig_fn sel_id NoDefMeth     -- No default method at all
1247       = do { traceTc "tc_def: warn" (ppr sel_id)
1248            ; (meth_id, _) <- mkMethIds sig_fn clas tyvars dfun_ev_vars
1249                                        inst_tys sel_id
1250            ; dflags <- getDynFlags
1251            ; return (meth_id,
1252                      mkVarBind meth_id $
1253                        mkLHsWrap lam_wrapper (error_rhs dflags)) }
1254       where
1255         error_rhs dflags = L inst_loc $ HsApp error_fun (error_msg dflags)
1256         error_fun    = L inst_loc $ wrapId (WpTyApp meth_tau) nO_METHOD_BINDING_ERROR_ID
1257         error_msg dflags = L inst_loc (HsLit (HsStringPrim (unsafeMkByteString (error_string dflags))))
1258         meth_tau     = funResultTy (applyTys (idType sel_id) inst_tys)
1259         error_string dflags = showSDoc dflags (hcat [ppr inst_loc, text "|", ppr sel_id ])
1260         lam_wrapper  = mkWpTyLams tyvars <.> mkWpLams dfun_ev_vars
1261
1262     tc_default sig_fn sel_id (DefMeth dm_name) -- A polymorphic default method
1263       = do {   -- Build the typechecked version directly,
1264                  -- without calling typecheck_method;
1265                  -- see Note [Default methods in instances]
1266                  -- Generate   /\as.\ds. let self = df as ds
1267                  --                      in $dm inst_tys self
1268                  -- The 'let' is necessary only because HsSyn doesn't allow
1269                  -- you to apply a function to a dictionary *expression*.
1270
1271            ; self_dict <- newDict clas inst_tys
1272            ; let self_ev_bind = EvBind self_dict
1273                                 (EvDFunApp dfun_id (mkTyVarTys tyvars) (map EvId dfun_ev_vars))
1274
1275            ; (meth_id, local_meth_sig) <- mkMethIds sig_fn clas tyvars dfun_ev_vars
1276                                                     inst_tys sel_id
1277            ; dm_id <- tcLookupId dm_name
1278            ; let dm_inline_prag = idInlinePragma dm_id
1279                  rhs = HsWrap (mkWpEvVarApps [self_dict] <.> mkWpTyApps inst_tys) $
1280                        HsVar dm_id
1281
1282                  local_meth_id = sig_id local_meth_sig
1283                  meth_bind = mkVarBind local_meth_id (L inst_loc rhs)
1284                  meth_id1 = meth_id `setInlinePragma` dm_inline_prag
1285                         -- Copy the inline pragma (if any) from the default
1286                         -- method to this version. Note [INLINE and default methods]
1287
1288                   
1289                  export = ABE { abe_wrap = idHsWrapper, abe_poly = meth_id1
1290                               , abe_mono = local_meth_id
1291                               , abe_prags = mk_meth_spec_prags meth_id1 [] }
1292                  bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars
1293                                  , abs_exports = [export]
1294                                  , abs_ev_binds = EvBinds (unitBag self_ev_bind)
1295                                  , abs_binds    = unitBag meth_bind }
1296              -- Default methods in an instance declaration can't have their own
1297              -- INLINE or SPECIALISE pragmas. It'd be possible to allow them, but
1298              -- currently they are rejected with
1299              --           "INLINE pragma lacks an accompanying binding"
1300
1301            ; return (meth_id1, L inst_loc bind) }
1302
1303     ----------------------
1304     mk_meth_spec_prags :: Id -> [LTcSpecPrag] -> TcSpecPrags
1305         -- Adapt the 'SPECIALISE instance' pragmas to work for this method Id
1306         -- There are two sources:
1307         --   * spec_prags_for_me: {-# SPECIALISE op :: <blah> #-}
1308         --   * spec_prags_from_inst: derived from {-# SPECIALISE instance :: <blah> #-}
1309         --     These ones have the dfun inside, but [perhaps surprisingly]
1310         --     the correct wrapper.
1311     mk_meth_spec_prags meth_id spec_prags_for_me
1312       = SpecPrags (spec_prags_for_me ++ spec_prags_from_inst)
1313       where
1314         spec_prags_from_inst
1315            | isInlinePragma (idInlinePragma meth_id)
1316            = []  -- Do not inherit SPECIALISE from the instance if the
1317                  -- method is marked INLINE, because then it'll be inlined
1318                  -- and the specialisation would do nothing. (Indeed it'll provoke
1319                  -- a warning from the desugarer
1320            | otherwise 
1321            = [ L inst_loc (SpecPrag meth_id wrap inl)
1322              | L inst_loc (SpecPrag _ wrap inl) <- spec_inst_prags]
1323
1324     inst_loc = getSrcSpan dfun_id
1325
1326         -- For instance decls that come from standalone deriving clauses
1327         -- we want to print out the full source code if there's an error
1328         -- because otherwise the user won't see the code at all
1329     add_meth_ctxt sel_id generated_code rn_bind thing
1330       | generated_code = addLandmarkErrCtxt (derivBindCtxt sel_id clas inst_tys rn_bind) thing
1331       | otherwise      = thing
1332
1333     ----------------------
1334
1335     -- check if one of the minimal complete definitions is satisfied
1336     checkMinimalDefinition
1337       = whenIsJust (isUnsatisfied methodExists (classMinimalDef clas)) $
1338           warnUnsatisifiedMinimalDefinition
1339       where
1340       methodExists meth = isJust (findMethodBind meth binds)
1341
1342 mkGenericDefMethBind :: Class -> [Type] -> Id -> Name -> TcM (LHsBind Name)
1343 mkGenericDefMethBind clas inst_tys sel_id dm_name
1344   =     -- A generic default method
1345         -- If the method is defined generically, we only have to call the
1346         -- dm_name.
1347     do  { dflags <- getDynFlags
1348         ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body"
1349                    (vcat [ppr clas <+> ppr inst_tys,
1350                           nest 2 (ppr sel_id <+> equals <+> ppr rhs)]))
1351
1352         ; return (noLoc $ mkTopFunBind Generated (noLoc (idName sel_id))
1353                                        [mkSimpleMatch [] rhs]) }
1354   where
1355     rhs = nlHsVar dm_name
1356
1357 ----------------------
1358 wrapId :: HsWrapper -> id -> HsExpr id
1359 wrapId wrapper id = mkHsWrap wrapper (HsVar id)
1360
1361 derivBindCtxt :: Id -> Class -> [Type ] -> LHsBind Name -> SDoc
1362 derivBindCtxt sel_id clas tys _bind
1363    = vcat [ ptext (sLit "When typechecking the code for ") <+> quotes (ppr sel_id)
1364           , nest 2 (ptext (sLit "in a standalone derived instance for")
1365                     <+> quotes (pprClassPred clas tys) <> colon)
1366           , nest 2 $ ptext (sLit "To see the code I am typechecking, use -ddump-deriv") ]
1367
1368 warnMissingMethodOrAT :: String -> Name -> TcM ()
1369 warnMissingMethodOrAT what name
1370   = do { warn <- woptM Opt_WarnMissingMethods
1371        ; traceTc "warn" (ppr name <+> ppr warn <+> ppr (not (startsWithUnderscore (getOccName name))))
1372        ; warnTc (warn  -- Warn only if -fwarn-missing-methods
1373                  && not (startsWithUnderscore (getOccName name)))
1374                                         -- Don't warn about _foo methods
1375                 (ptext (sLit "No explicit") <+> text what <+> ptext (sLit "or default declaration for")
1376                  <+> quotes (ppr name)) }
1377
1378 warnUnsatisifiedMinimalDefinition :: ClassMinimalDef -> TcM ()
1379 warnUnsatisifiedMinimalDefinition mindef
1380   = do { warn <- woptM Opt_WarnMissingMethods
1381        ; warnTc warn message
1382        }
1383   where
1384     message = vcat [ptext (sLit "No explicit implementation for")
1385                    ,nest 2 $ pprBooleanFormulaNice mindef
1386                    ]
1387 \end{code}
1388
1389 Note [Export helper functions]
1390 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1391 We arrange to export the "helper functions" of an instance declaration,
1392 so that they are not subject to preInlineUnconditionally, even if their
1393 RHS is trivial.  Reason: they are mentioned in the DFunUnfolding of
1394 the dict fun as Ids, not as CoreExprs, so we can't substitute a
1395 non-variable for them.
1396
1397 We could change this by making DFunUnfoldings have CoreExprs, but it
1398 seems a bit simpler this way.
1399
1400 Note [Default methods in instances]
1401 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1402 Consider this
1403
1404    class Baz v x where
1405       foo :: x -> x
1406       foo y = <blah>
1407
1408    instance Baz Int Int
1409
1410 From the class decl we get
1411
1412    $dmfoo :: forall v x. Baz v x => x -> x
1413    $dmfoo y = <blah>
1414
1415 Notice that the type is ambiguous.  That's fine, though. The instance
1416 decl generates
1417
1418    $dBazIntInt = MkBaz fooIntInt
1419    fooIntInt = $dmfoo Int Int $dBazIntInt
1420
1421 BUT this does mean we must generate the dictionary translation of
1422 fooIntInt directly, rather than generating source-code and
1423 type-checking it.  That was the bug in Trac #1061. In any case it's
1424 less work to generate the translated version!
1425
1426 Note [INLINE and default methods]
1427 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1428 Default methods need special case.  They are supposed to behave rather like
1429 macros.  For exmample
1430
1431   class Foo a where
1432     op1, op2 :: Bool -> a -> a
1433
1434     {-# INLINE op1 #-}
1435     op1 b x = op2 (not b) x
1436
1437   instance Foo Int where
1438     -- op1 via default method
1439     op2 b x = <blah>
1440
1441 The instance declaration should behave
1442
1443    just as if 'op1' had been defined with the
1444    code, and INLINE pragma, from its original
1445    definition.
1446
1447 That is, just as if you'd written
1448
1449   instance Foo Int where
1450     op2 b x = <blah>
1451
1452     {-# INLINE op1 #-}
1453     op1 b x = op2 (not b) x
1454
1455 So for the above example we generate:
1456
1457   {-# INLINE $dmop1 #-}
1458   -- $dmop1 has an InlineCompulsory unfolding
1459   $dmop1 d b x = op2 d (not b) x
1460
1461   $fFooInt = MkD $cop1 $cop2
1462
1463   {-# INLINE $cop1 #-}
1464   $cop1 = $dmop1 $fFooInt
1465
1466   $cop2 = <blah>
1467
1468 Note carefullly:
1469
1470 * We *copy* any INLINE pragma from the default method $dmop1 to the
1471   instance $cop1.  Otherwise we'll just inline the former in the
1472   latter and stop, which isn't what the user expected
1473
1474 * Regardless of its pragma, we give the default method an
1475   unfolding with an InlineCompulsory source. That means
1476   that it'll be inlined at every use site, notably in
1477   each instance declaration, such as $cop1.  This inlining
1478   must happen even though
1479     a) $dmop1 is not saturated in $cop1
1480     b) $cop1 itself has an INLINE pragma
1481
1482   It's vital that $dmop1 *is* inlined in this way, to allow the mutual
1483   recursion between $fooInt and $cop1 to be broken
1484
1485 * To communicate the need for an InlineCompulsory to the desugarer
1486   (which makes the Unfoldings), we use the IsDefaultMethod constructor
1487   in TcSpecPrags.
1488
1489
1490 %************************************************************************
1491 %*                                                                      *
1492 \subsection{Error messages}
1493 %*                                                                      *
1494 %************************************************************************
1495
1496 \begin{code}
1497 instDeclCtxt1 :: LHsType Name -> SDoc
1498 instDeclCtxt1 hs_inst_ty
1499   = inst_decl_ctxt (case unLoc hs_inst_ty of
1500                         HsForAllTy _ _ _ (L _ ty') -> ppr ty'
1501                         _                          -> ppr hs_inst_ty)     -- Don't expect this
1502 instDeclCtxt2 :: Type -> SDoc
1503 instDeclCtxt2 dfun_ty
1504   = inst_decl_ctxt (ppr (mkClassPred cls tys))
1505   where
1506     (_,_,cls,tys) = tcSplitDFunTy dfun_ty
1507
1508 inst_decl_ctxt :: SDoc -> SDoc
1509 inst_decl_ctxt doc = hang (ptext (sLit "In the instance declaration for"))
1510                         2 (quotes doc)
1511
1512 badBootFamInstDeclErr :: SDoc
1513 badBootFamInstDeclErr
1514   = ptext (sLit "Illegal family instance in hs-boot file")
1515
1516 notFamily :: TyCon -> SDoc
1517 notFamily tycon
1518   = vcat [ ptext (sLit "Illegal family instance for") <+> quotes (ppr tycon)
1519          , nest 2 $ parens (ppr tycon <+> ptext (sLit "is not an indexed type family"))]
1520
1521 tooFewParmsErr :: Arity -> SDoc
1522 tooFewParmsErr arity
1523   = ptext (sLit "Family instance has too few parameters; expected") <+>
1524     ppr arity
1525
1526 assocInClassErr :: Located Name -> SDoc
1527 assocInClassErr name
1528  = ptext (sLit "Associated type") <+> quotes (ppr name) <+>
1529    ptext (sLit "must be inside a class instance")
1530
1531 badFamInstDecl :: Located Name -> SDoc
1532 badFamInstDecl tc_name
1533   = vcat [ ptext (sLit "Illegal family instance for") <+>
1534            quotes (ppr tc_name)
1535          , nest 2 (parens $ ptext (sLit "Use TypeFamilies to allow indexed type families")) ]
1536
1537 notOpenFamily :: TyCon -> SDoc
1538 notOpenFamily tc
1539   = ptext (sLit "Illegal instance for closed family") <+> quotes (ppr tc)
1540 \end{code}