Revert "Fix a couple test failures encountered when building on Windows"
[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,
55                     oldTypeableClassNames, genericClassNames )
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) $ forM_ local_infos $ \x -> case x of
419              _ | typInstCheck x -> addErrAt (getSrcSpan $ iSpec x) (typInstErr x)
420              _ | genInstCheck x -> addErrAt (getSrcSpan $ iSpec x) (genInstErr x)
421              _ -> return ()
422
423        -- As above but for Safe Inference mode.
424        ; when (safeInferOn dflags) $ forM_ local_infos $ \x -> case x of
425              _ | typInstCheck x -> recordUnsafeInfer
426              _ | genInstCheck x -> recordUnsafeInfer
427              _ | overlapCheck x -> recordUnsafeInfer
428              _ -> return ()
429
430        ; return ( gbl_env
431                 , bagToList deriv_inst_info ++ local_infos
432                 , deriv_binds)
433     }}
434   where
435     -- Separate the Typeable instances from the rest
436     splitTypeable _   []     = ([],[])
437     splitTypeable env (i:is) =
438       let (typeableInsts, otherInsts) = splitTypeable env is
439       in if -- We will filter out instances of Typeable
440             (typeableClassName == is_cls_nm (iSpec i))
441             -- but not those that come from Data.Typeable.Internal
442             && tcg_mod env /= tYPEABLE_INTERNAL
443             -- nor those from an .hs-boot file (deriving can't be used there)
444             && not (isHsBoot (tcg_src env))
445          then (i:typeableInsts, otherInsts)
446          else (typeableInsts, i:otherInsts)
447
448     typInstCheck ty = is_cls_nm (iSpec ty) `elem` oldTypeableClassNames
449     typInstErr i = hang (ptext (sLit $ "Typeable instances can only be "
450                             ++ "derived in Safe Haskell.") $+$ 
451                          ptext (sLit "Replace the following instance:"))
452                      2 (pprInstanceHdr (iSpec i))
453
454     overlapCheck ty = overlapMode (is_flag $ iSpec ty) `elem`
455                         [Overlappable, Overlapping, Overlaps]
456     genInstCheck ty = is_cls_nm (iSpec ty) `elem` genericClassNames
457     genInstErr i = hang (ptext (sLit $ "Generic instances can only be "
458                             ++ "derived in Safe Haskell.") $+$ 
459                          ptext (sLit "Replace the following instance:"))
460                      2 (pprInstanceHdr (iSpec i))
461
462     instMsg i = hang (ptext (sLit $ "Typeable instances can only be derived; replace "
463                                  ++ "the following instance:"))
464                      2 (pprInstance (iSpec i))
465
466 addClsInsts :: [InstInfo Name] -> TcM a -> TcM a
467 addClsInsts infos thing_inside
468   = tcExtendLocalInstEnv (map iSpec infos) thing_inside
469
470 addFamInsts :: [FamInst] -> TcM a -> TcM a
471 -- Extend (a) the family instance envt
472 --        (b) the type envt with stuff from data type decls
473 addFamInsts fam_insts thing_inside
474   = tcExtendLocalFamInstEnv fam_insts $ 
475     tcExtendGlobalEnv things  $ 
476     do { traceTc "addFamInsts" (pprFamInsts fam_insts)
477        ; tcg_env <- tcAddImplicits things
478        ; setGblEnv tcg_env thing_inside }
479   where
480     axioms = map (toBranchedAxiom . famInstAxiom) fam_insts
481     tycons = famInstsRepTyCons fam_insts
482     things = map ATyCon tycons ++ map ACoAxiom axioms 
483 \end{code}
484
485 Note [Deriving inside TH brackets]
486 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
487 Given a declaration bracket
488   [d| data T = A | B deriving( Show ) |]
489
490 there is really no point in generating the derived code for deriving(
491 Show) and then type-checking it. This will happen at the call site
492 anyway, and the type check should never fail!  Moreover (Trac #6005)
493 the scoping of the generated code inside the bracket does not seem to 
494 work out.  
495
496 The easy solution is simply not to generate the derived instances at
497 all.  (A less brutal solution would be to generate them with no
498 bindings.)  This will become moot when we shift to the new TH plan, so 
499 the brutal solution will do.
500
501
502 \begin{code}
503 tcLocalInstDecl :: LInstDecl Name
504                 -> TcM ([InstInfo Name], [FamInst])
505         -- A source-file instance declaration
506         -- Type-check all the stuff before the "where"
507         --
508         -- We check for respectable instance type, and context
509 tcLocalInstDecl (L loc (TyFamInstD { tfid_inst = decl }))
510   = do { fam_inst <- tcTyFamInstDecl Nothing (L loc decl)
511        ; return ([], [fam_inst]) }
512
513 tcLocalInstDecl (L loc (DataFamInstD { dfid_inst = decl }))
514   = do { fam_inst <- tcDataFamInstDecl Nothing (L loc decl)
515        ; return ([], [fam_inst]) }
516
517 tcLocalInstDecl (L loc (ClsInstD { cid_inst = decl }))
518   = do { (insts, fam_insts) <- tcClsInstDecl (L loc decl)
519        ; return (insts, fam_insts) }
520
521 tcClsInstDecl :: LClsInstDecl Name -> TcM ([InstInfo Name], [FamInst])
522 tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds
523                                   , cid_sigs = uprags, cid_tyfam_insts = ats
524                                   , cid_overlap_mode = overlap_mode
525                                   , cid_datafam_insts = adts }))
526   = setSrcSpan loc                      $
527     addErrCtxt (instDeclCtxt1 poly_ty)  $
528     do  { is_boot <- tcIsHsBoot
529         ; checkTc (not is_boot || (isEmptyLHsBinds binds && null uprags))
530                   badBootDeclErr
531
532         ; (tyvars, theta, clas, inst_tys) <- tcHsInstHead InstDeclCtxt poly_ty
533         ; let mini_env   = mkVarEnv (classTyVars clas `zip` inst_tys)
534               mini_subst = mkTvSubst (mkInScopeSet (mkVarSet tyvars)) mini_env
535               mb_info    = Just (clas, mini_env)
536                            
537         -- Next, process any associated types.
538         ; traceTc "tcLocalInstDecl" (ppr poly_ty)
539         ; tyfam_insts0 <- tcExtendTyVarEnv tyvars $
540                           mapAndRecoverM (tcAssocTyDecl clas mini_env) ats
541         ; datafam_insts <- tcExtendTyVarEnv tyvars $
542                            mapAndRecoverM (tcDataFamInstDecl mb_info) adts
543
544         -- Check for missing associated types and build them
545         -- from their defaults (if available)
546         ; let defined_ats = mkNameSet (map (tyFamInstDeclName . unLoc) ats)
547                             `unionNameSets` 
548                             mkNameSet (map (unLoc . dfid_tycon . unLoc) adts)
549         ; tyfam_insts1 <- mapM (tcATDefault mini_subst defined_ats) 
550                                (classATItems clas)
551         
552         -- Finally, construct the Core representation of the instance.
553         -- (This no longer includes the associated types.)
554         ; dfun_name <- newDFunName clas inst_tys (getLoc poly_ty)
555                 -- Dfun location is that of instance *header*
556
557         ; overlap_flag <-
558             do defaultOverlapFlag <- getOverlapFlag
559                return $ setOverlapModeMaybe defaultOverlapFlag overlap_mode
560         ; (subst, tyvars') <- tcInstSkolTyVars tyvars
561         ; let dfun      = mkDictFunId dfun_name tyvars theta clas inst_tys
562               ispec     = mkLocalInstance dfun overlap_flag tyvars' clas (substTys subst inst_tys)
563                             -- Be sure to freshen those type variables, 
564                             -- so they are sure not to appear in any lookup
565               inst_info = InstInfo { iSpec  = ispec
566                                    , iBinds = InstBindings
567                                      { ib_binds = binds
568                                      , ib_pragmas = uprags
569                                      , ib_extensions = []
570                                      , ib_standalone_deriving = False } }
571
572         ; return ( [inst_info], tyfam_insts0 ++ concat tyfam_insts1 ++ datafam_insts) }
573
574
575 tcATDefault :: TvSubst -> NameSet -> ClassATItem -> TcM [FamInst]
576 -- ^ Construct default instances for any associated types that
577 -- aren't given a user definition
578 -- Returns [] or singleton
579 tcATDefault inst_subst defined_ats (ATI fam_tc defs)
580   -- User supplied instances ==> everything is OK
581   | tyConName fam_tc `elemNameSet` defined_ats
582   = return []
583
584   -- No user instance, have defaults ==> instatiate them
585    -- Example:   class C a where { type F a b :: *; type F a b = () }
586    --            instance C [x]
587    -- Then we want to generate the decl:   type F [x] b = ()
588   | Just rhs_ty <- defs
589   = do { let (subst', pat_tys') = mapAccumL subst_tv inst_subst
590                                             (tyConTyVars fam_tc)
591              rhs'     = substTy subst' rhs_ty
592              tv_set'  = tyVarsOfTypes pat_tys'
593              tvs'     = varSetElemsKvsFirst tv_set'
594        ; rep_tc_name <- newFamInstTyConName (noLoc (tyConName fam_tc)) pat_tys'
595        ; let axiom = mkSingleCoAxiom rep_tc_name tvs' fam_tc pat_tys' rhs'
596        ; traceTc "mk_deflt_at_instance" (vcat [ ppr fam_tc, ppr rhs_ty
597                                               , pprCoAxiom axiom ])
598        ; fam_inst <- ASSERT( tyVarsOfType rhs' `subVarSet` tv_set' ) 
599                      newFamInst SynFamilyInst axiom
600        ; return [fam_inst] }
601
602    -- No defaults ==> generate a warning
603   | otherwise  -- defs = Nothing
604   = do { warnMissingMethodOrAT "associated type" (tyConName fam_tc)
605        ; return [] }
606   where
607     subst_tv subst tc_tv 
608       | Just ty <- lookupVarEnv (getTvSubstEnv subst) tc_tv
609       = (subst, ty)
610       | otherwise
611       = (extendTvSubst subst tc_tv ty', ty')
612       where
613         ty' = mkTyVarTy (updateTyVarKind (substTy subst) tc_tv)
614                            
615
616 --------------
617 tcAssocTyDecl :: Class                   -- Class of associated type
618               -> VarEnv Type             -- Instantiation of class TyVars
619               -> LTyFamInstDecl Name     
620               -> TcM (FamInst)
621 tcAssocTyDecl clas mini_env ldecl
622   = do { fam_inst <- tcTyFamInstDecl (Just (clas, mini_env)) ldecl
623        ; return fam_inst }
624 \end{code}
625
626 %************************************************************************
627 %*                                                                      *
628                Type checking family instances
629 %*                                                                      *
630 %************************************************************************
631
632 Family instances are somewhat of a hybrid.  They are processed together with
633 class instance heads, but can contain data constructors and hence they share a
634 lot of kinding and type checking code with ordinary algebraic data types (and
635 GADTs).
636
637 \begin{code}
638 tcFamInstDeclCombined :: Maybe (Class, VarEnv Type) -- the class & mini_env if applicable
639                       -> Located Name -> TcM TyCon
640 tcFamInstDeclCombined mb_clsinfo fam_tc_lname
641   = do { -- Type family instances require -XTypeFamilies
642          -- and can't (currently) be in an hs-boot file
643        ; traceTc "tcFamInstDecl" (ppr fam_tc_lname)
644        ; type_families <- xoptM Opt_TypeFamilies
645        ; is_boot <- tcIsHsBoot   -- Are we compiling an hs-boot file?
646        ; checkTc type_families $ badFamInstDecl fam_tc_lname
647        ; checkTc (not is_boot) $ badBootFamInstDeclErr
648
649        -- Look up the family TyCon and check for validity including
650        -- check that toplevel type instances are not for associated types.
651        ; fam_tc <- tcLookupLocatedTyCon fam_tc_lname
652        ; when (isNothing mb_clsinfo &&   -- Not in a class decl
653                isTyConAssoc fam_tc)      -- but an associated type
654               (addErr $ assocInClassErr fam_tc_lname)
655
656        ; return fam_tc }
657
658 tcTyFamInstDecl :: Maybe (Class, VarEnv Type) -- the class & mini_env if applicable
659                 -> LTyFamInstDecl Name -> TcM FamInst
660   -- "type instance"
661 tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn }))
662   = setSrcSpan loc           $
663     tcAddTyFamInstCtxt decl  $
664     do { let fam_lname = tfe_tycon (unLoc eqn)
665        ; fam_tc <- tcFamInstDeclCombined mb_clsinfo fam_lname
666
667          -- (0) Check it's an open type family
668        ; checkTc (isFamilyTyCon fam_tc)        (notFamily fam_tc)
669        ; checkTc (isSynFamilyTyCon fam_tc)     (wrongKindOfFamily fam_tc)
670        ; checkTc (isOpenSynFamilyTyCon fam_tc) (notOpenFamily fam_tc)
671
672          -- (1) do the work of verifying the synonym group
673        ; co_ax_branch <- tcTyFamInstEqn (famTyConShape fam_tc) eqn
674
675          -- (2) check for validity
676        ; checkValidTyFamInst mb_clsinfo fam_tc co_ax_branch
677
678          -- (3) construct coercion axiom
679        ; rep_tc_name <- newFamInstAxiomName loc (unLoc fam_lname)
680                                             [co_ax_branch]
681        ; let axiom = mkUnbranchedCoAxiom rep_tc_name fam_tc co_ax_branch
682        ; newFamInst SynFamilyInst axiom }
683
684 tcDataFamInstDecl :: Maybe (Class, VarEnv Type)
685                   -> LDataFamInstDecl Name -> TcM FamInst
686   -- "newtype instance" and "data instance"
687 tcDataFamInstDecl mb_clsinfo 
688     (L loc decl@(DataFamInstDecl
689        { dfid_pats = pats
690        , dfid_tycon = fam_tc_name
691        , dfid_defn = defn@HsDataDefn { dd_ND = new_or_data, dd_cType = cType
692                                      , dd_ctxt = ctxt, dd_cons = cons } }))
693   = setSrcSpan loc             $
694     tcAddDataFamInstCtxt decl  $
695     do { fam_tc <- tcFamInstDeclCombined mb_clsinfo fam_tc_name
696
697          -- Check that the family declaration is for the right kind
698        ; checkTc (isFamilyTyCon fam_tc) (notFamily fam_tc)
699        ; checkTc (isAlgTyCon fam_tc) (wrongKindOfFamily fam_tc)
700
701          -- Kind check type patterns
702        ; tcFamTyPats (famTyConShape fam_tc) pats
703                      (kcDataDefn defn) $ 
704            \tvs' pats' res_kind -> do
705
706        { -- Check that left-hand side contains no type family applications
707          -- (vanilla synonyms are fine, though, and we checked for
708          --  foralls earlier)
709          checkValidFamPats fam_tc tvs' pats'
710          -- Check that type patterns match class instance head, if any
711        ; checkConsistentFamInst mb_clsinfo fam_tc tvs' pats'
712          
713          -- Result kind must be '*' (otherwise, we have too few patterns)
714        ; checkTc (isLiftedTypeKind res_kind) $ tooFewParmsErr (tyConArity fam_tc)
715
716        ; stupid_theta <- tcHsContext ctxt
717        ; gadt_syntax <- dataDeclChecks (tyConName fam_tc) new_or_data stupid_theta cons
718
719          -- Construct representation tycon
720        ; rep_tc_name <- newFamInstTyConName fam_tc_name pats'
721        ; axiom_name  <- newImplicitBinder rep_tc_name mkInstTyCoOcc
722        ; let orig_res_ty = mkTyConApp fam_tc pats'
723
724        ; (rep_tc, fam_inst) <- fixM $ \ ~(rec_rep_tc, _) ->
725            do { data_cons <- tcConDecls new_or_data rec_rep_tc
726                                        (tvs', orig_res_ty) cons
727               ; tc_rhs <- case new_or_data of
728                      DataType -> return (mkDataTyConRhs data_cons)
729                      NewType  -> ASSERT( not (null data_cons) )
730                                  mkNewTyConRhs rep_tc_name rec_rep_tc (head data_cons)
731               -- freshen tyvars
732               ; let (eta_tvs, eta_pats) = eta_reduce tvs' pats'
733                     axiom    = mkSingleCoAxiom axiom_name eta_tvs fam_tc eta_pats 
734                                                (mkTyConApp rep_tc (mkTyVarTys eta_tvs))
735                     parent   = FamInstTyCon axiom fam_tc pats'
736                     roles    = map (const Nominal) tvs'
737                     rep_tc   = buildAlgTyCon rep_tc_name tvs' roles cType stupid_theta tc_rhs 
738                                              Recursive 
739                                              False      -- No promotable to the kind level
740                                              gadt_syntax parent
741                  -- We always assume that indexed types are recursive.  Why?
742                  -- (1) Due to their open nature, we can never be sure that a
743                  -- further instance might not introduce a new recursive
744                  -- dependency.  (2) They are always valid loop breakers as
745                  -- they involve a coercion.
746               ; fam_inst <- newFamInst (DataFamilyInst rep_tc) axiom
747               ; return (rep_tc, fam_inst) }
748
749          -- Remember to check validity; no recursion to worry about here
750        ; checkValidTyCon rep_tc
751        ; return fam_inst } }
752   where
753     -- See Note [Eta reduction for data family axioms]
754     --  [a,b,c,d].T [a] c Int c d  ==>  [a,b,c]. T [a] c Int c
755     eta_reduce tvs pats = go (reverse tvs) (reverse pats)
756     go (tv:tvs) (pat:pats)
757       | Just tv' <- getTyVar_maybe pat
758       , tv == tv'
759       , not (tv `elemVarSet` tyVarsOfTypes pats)
760       = go tvs pats
761     go tvs pats = (reverse tvs, reverse pats)
762
763 \end{code}
764
765 Note [Eta reduction for data family axioms]
766 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
767 Consider this
768    data family T a b :: *
769    newtype instance T Int a = MkT (IO a) deriving( Monad )
770 We'd like this to work.  From the 'newtype instance' you might
771 think we'd get:
772    newtype TInt a = MkT (IO a)
773    axiom ax1 a :: T Int a ~ TInt a   -- The type-instance part
774    axiom ax2 a :: TInt a ~ IO a      -- The newtype part
775
776 But now what can we do?  We have this problem
777    Given:   d  :: Monad IO
778    Wanted:  d' :: Monad (T Int) = d |> ????
779 What coercion can we use for the ???
780
781 Solution: eta-reduce both axioms, thus:
782    axiom ax1 :: T Int ~ TInt
783    axiom ax2 :: TInt ~ IO
784 Now
785    d' = d |> Monad (sym (ax2 ; ax1))
786
787 This eta reduction happens both for data instances and newtype instances.
788
789 See Note [Newtype eta] in TyCon.
790
791
792
793 %************************************************************************
794 %*                                                                      *
795       Type-checking instance declarations, pass 2
796 %*                                                                      *
797 %************************************************************************
798
799 \begin{code}
800 tcInstDecls2 :: [LTyClDecl Name] -> [InstInfo Name]
801              -> TcM (LHsBinds Id)
802 -- (a) From each class declaration,
803 --      generate any default-method bindings
804 -- (b) From each instance decl
805 --      generate the dfun binding
806
807 tcInstDecls2 tycl_decls inst_decls
808   = do  { -- (a) Default methods from class decls
809           let class_decls = filter (isClassDecl . unLoc) tycl_decls
810         ; dm_binds_s <- mapM tcClassDecl2 class_decls
811         ; let dm_binds = unionManyBags dm_binds_s
812
813           -- (b) instance declarations
814         ; let dm_ids = collectHsBindsBinders dm_binds
815               -- Add the default method Ids (again)
816               -- See Note [Default methods and instances]
817         ; inst_binds_s <- tcExtendLetEnv TopLevel TopLevel dm_ids $
818                           mapM tcInstDecl2 inst_decls
819
820           -- Done
821         ; return (dm_binds `unionBags` unionManyBags inst_binds_s) }
822 \end{code}
823
824 See Note [Default methods and instances]
825 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
826 The default method Ids are already in the type environment (see Note
827 [Default method Ids and Template Haskell] in TcTyClsDcls), BUT they
828 don't have their InlinePragmas yet.  Usually that would not matter,
829 because the simplifier propagates information from binding site to
830 use.  But, unusually, when compiling instance decls we *copy* the
831 INLINE pragma from the default method to the method for that
832 particular operation (see Note [INLINE and default methods] below).
833
834 So right here in tcInstDecls2 we must re-extend the type envt with
835 the default method Ids replete with their INLINE pragmas.  Urk.
836
837 \begin{code}
838
839 tcInstDecl2 :: InstInfo Name -> TcM (LHsBinds Id)
840             -- Returns a binding for the dfun
841 tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
842   = recoverM (return emptyLHsBinds)             $
843     setSrcSpan loc                              $
844     addErrCtxt (instDeclCtxt2 (idType dfun_id)) $
845     do {  -- Instantiate the instance decl with skolem constants
846        ; (inst_tyvars, dfun_theta, inst_head) <- tcSkolDFunType (idType dfun_id)
847                      -- We instantiate the dfun_id with superSkolems.
848                      -- See Note [Subtle interaction of recursion and overlap]
849                      -- and Note [Binding when looking up instances]
850        ; let (clas, inst_tys) = tcSplitDFunHead inst_head
851              (class_tyvars, sc_theta, _, op_items) = classBigSig clas
852              sc_theta' = substTheta (zipOpenTvSubst class_tyvars inst_tys) sc_theta
853
854        ; dfun_ev_vars <- newEvVars dfun_theta
855
856        ; (sc_binds, sc_ev_vars) <- tcSuperClasses dfun_id inst_tyvars dfun_ev_vars sc_theta'
857
858        -- Deal with 'SPECIALISE instance' pragmas
859        -- See Note [SPECIALISE instance pragmas]
860        ; spec_inst_info@(spec_inst_prags,_) <- tcSpecInstPrags dfun_id ibinds
861
862         -- Typecheck the methods
863        ; (meth_ids, meth_binds)
864            <- tcExtendTyVarEnv inst_tyvars $
865                 -- The inst_tyvars scope over the 'where' part
866                 -- Those tyvars are inside the dfun_id's type, which is a bit
867                 -- bizarre, but OK so long as you realise it!
868               tcInstanceMethods dfun_id clas inst_tyvars dfun_ev_vars
869                                 inst_tys spec_inst_info
870                                 op_items ibinds
871
872        -- Create the result bindings
873        ; self_dict <- newDict clas inst_tys
874        ; let class_tc      = classTyCon clas
875              [dict_constr] = tyConDataCons class_tc
876              dict_bind     = mkVarBind self_dict (L loc con_app_args)
877
878                      -- We don't produce a binding for the dict_constr; instead we
879                      -- rely on the simplifier to unfold this saturated application
880                      -- We do this rather than generate an HsCon directly, because
881                      -- it means that the special cases (e.g. dictionary with only one
882                      -- member) are dealt with by the common MkId.mkDataConWrapId
883                      -- code rather than needing to be repeated here.
884                      --    con_app_tys  = MkD ty1 ty2
885                      --    con_app_scs  = MkD ty1 ty2 sc1 sc2
886                      --    con_app_args = MkD ty1 ty2 sc1 sc2 op1 op2
887              con_app_tys  = wrapId (mkWpTyApps inst_tys)
888                                    (dataConWrapId dict_constr)
889              con_app_scs  = mkHsWrap (mkWpEvApps (map EvId sc_ev_vars)) con_app_tys
890              con_app_args = foldl app_to_meth con_app_scs meth_ids
891
892              app_to_meth :: HsExpr Id -> Id -> HsExpr Id
893              app_to_meth fun meth_id = L loc fun `HsApp` L loc (wrapId arg_wrapper meth_id)
894
895              inst_tv_tys = mkTyVarTys inst_tyvars
896              arg_wrapper = mkWpEvVarApps dfun_ev_vars <.> mkWpTyApps inst_tv_tys
897
898                 -- Do not inline the dfun; instead give it a magic DFunFunfolding
899                 -- See Note [ClassOp/DFun selection]
900                 -- See also note [Single-method classes]
901              (dfun_id_w_fun, dfun_spec_prags)
902                 | isNewTyCon class_tc
903                 = ( dfun_id `setInlinePragma` alwaysInlinePragma { inl_sat = Just 0 }
904                   , SpecPrags [] )   -- Newtype dfuns just inline unconditionally,
905                                      -- so don't attempt to specialise them
906                 | otherwise
907                 = ( dfun_id `setIdUnfolding`  mkDFunUnfolding (inst_tyvars ++ dfun_ev_vars)
908                                                               dict_constr dfun_args
909                             `setInlinePragma` dfunInlinePragma
910                   , SpecPrags spec_inst_prags )
911
912              dfun_args :: [CoreExpr]
913              dfun_args = map Type inst_tys        ++
914                          map Var  sc_ev_vars      ++ 
915                          map mk_meth_app meth_ids
916              mk_meth_app meth_id = Var meth_id `mkTyApps` inst_tv_tys `mkVarApps` dfun_ev_vars 
917
918              export = ABE { abe_wrap = idHsWrapper, abe_poly = dfun_id_w_fun
919                           , abe_mono = self_dict, abe_prags = dfun_spec_prags }
920                           -- NB: see Note [SPECIALISE instance pragmas]
921              main_bind = AbsBinds { abs_tvs = inst_tyvars
922                                   , abs_ev_vars = dfun_ev_vars
923                                   , abs_exports = [export]
924                                   , abs_ev_binds = sc_binds
925                                   , abs_binds = unitBag dict_bind }
926
927        ; return (unitBag (L loc main_bind) `unionBags`
928                  listToBag meth_binds)
929        }
930  where
931    dfun_id = instanceDFunId ispec
932    loc     = getSrcSpan dfun_id
933
934 ------------------------------
935 tcSuperClasses :: DFunId -> [TcTyVar] -> [EvVar] -> TcThetaType
936                -> TcM (TcEvBinds, [EvVar])
937 -- See Note [Silent superclass arguments]
938 tcSuperClasses dfun_id inst_tyvars dfun_ev_vars sc_theta
939   = do {   -- Check that all superclasses can be deduced from
940            -- the originally-specified dfun arguments
941        ; (sc_binds, sc_evs) <- checkConstraints InstSkol inst_tyvars orig_ev_vars $
942                                emitWanteds ScOrigin sc_theta
943
944        ; if null inst_tyvars && null dfun_ev_vars 
945          then return (sc_binds,       sc_evs)
946          else return (emptyTcEvBinds, sc_lam_args) }
947   where
948     n_silent     = dfunNSilent dfun_id
949     orig_ev_vars = drop n_silent dfun_ev_vars
950
951     sc_lam_args = map (find dfun_ev_vars) sc_theta
952     find [] pred 
953       = pprPanic "tcInstDecl2" (ppr dfun_id $$ ppr (idType dfun_id) $$ ppr pred)
954     find (ev:evs) pred 
955       | pred `eqPred` evVarPred ev = ev
956       | otherwise                  = find evs pred
957
958 ----------------------
959 mkMethIds :: HsSigFun -> Class -> [TcTyVar] -> [EvVar] 
960           -> [TcType] -> Id -> TcM (TcId, TcSigInfo)
961 mkMethIds sig_fn clas tyvars dfun_ev_vars inst_tys sel_id
962   = do  { let sel_occ = nameOccName sel_name
963         ; meth_name <- newName (mkClassOpAuxOcc sel_occ)
964         ; local_meth_name <- newName sel_occ
965                   -- Base the local_meth_name on the selector name, because
966                   -- type errors from tcInstanceMethodBody come from here
967
968         ; local_meth_sig <- case lookupHsSig sig_fn sel_name of
969             Just hs_ty  -- There is a signature in the instance declaration
970                -> do { sig_ty <- check_inst_sig hs_ty
971                      ; instTcTySig hs_ty sig_ty local_meth_name }
972
973             Nothing     -- No type signature
974                -> do { loc <- getSrcSpanM
975                      ; instTcTySigFromId loc (mkLocalId local_meth_name local_meth_ty) }
976               -- Absent a type sig, there are no new scoped type variables here
977               -- Only the ones from the instance decl itself, which are already
978               -- in scope.  Example:
979               --      class C a where { op :: forall b. Eq b => ... }
980               --      instance C [c] where { op = <rhs> }
981               -- In <rhs>, 'c' is scope but 'b' is not!
982
983         ; let meth_id = mkLocalId meth_name meth_ty
984         ; return (meth_id, local_meth_sig) }
985   where
986     sel_name      = idName sel_id
987     local_meth_ty = instantiateMethod clas sel_id inst_tys
988     meth_ty       = mkForAllTys tyvars $ mkPiTypes dfun_ev_vars local_meth_ty
989
990     -- Check that any type signatures have exactly the right type
991     check_inst_sig hs_ty@(L loc _) 
992        = setSrcSpan loc $ 
993          do { sig_ty <- tcHsSigType (FunSigCtxt sel_name) hs_ty
994             ; inst_sigs <- xoptM Opt_InstanceSigs
995             ; if inst_sigs then 
996                 unless (sig_ty `eqType` local_meth_ty)
997                        (badInstSigErr sel_name local_meth_ty)
998               else
999                 addErrTc (misplacedInstSig sel_name hs_ty)
1000             ; return sig_ty }
1001
1002 badInstSigErr :: Name -> Type -> TcM ()
1003 badInstSigErr meth ty
1004   = do { env0 <- tcInitTidyEnv
1005        ; let tidy_ty = tidyType env0 ty
1006                  -- Tidy the type using the ambient TidyEnv, 
1007                  -- to avoid apparent name capture (Trac #7475)
1008                  --    class C a where { op :: a -> b }
1009                  --    instance C (a->b) where
1010                  --       op :: forall x. x
1011                  --       op = ...blah...
1012        ; addErrTc (hang (ptext (sLit "Method signature does not match class; it should be"))
1013                       2 (pprPrefixName meth <+> dcolon <+> ppr tidy_ty)) }
1014
1015 misplacedInstSig :: Name -> LHsType Name -> SDoc
1016 misplacedInstSig name hs_ty
1017   = vcat [ hang (ptext (sLit "Illegal type signature in instance declaration:"))
1018               2 (hang (pprPrefixName name)
1019                     2 (dcolon <+> ppr hs_ty))
1020          , ptext (sLit "(Use InstanceSigs to allow this)") ]
1021
1022 ------------------------------
1023 tcSpecInstPrags :: DFunId -> InstBindings Name
1024                 -> TcM ([Located TcSpecPrag], PragFun)
1025 tcSpecInstPrags dfun_id (InstBindings { ib_binds = binds, ib_pragmas = uprags })
1026   = do { spec_inst_prags <- mapM (wrapLocM (tcSpecInst dfun_id)) $
1027                             filter isSpecInstLSig uprags
1028              -- The filter removes the pragmas for methods
1029        ; return (spec_inst_prags, mkPragFun uprags binds) }
1030 \end{code}
1031
1032 Note [Silent superclass arguments]
1033 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1034 See Trac #3731, #4809, #5751, #5913, #6117, which all
1035 describe somewhat more complicated situations, but ones
1036 encountered in practice.  
1037
1038       THE PROBLEM
1039
1040 The problem is that it is all too easy to create a class whose
1041 superclass is bottom when it should not be.
1042
1043 Consider the following (extreme) situation:
1044         class C a => D a where ...
1045         instance D [a] => D [a] where ...
1046 Although this looks wrong (assume D [a] to prove D [a]), it is only a
1047 more extreme case of what happens with recursive dictionaries, and it
1048 can, just about, make sense because the methods do some work before
1049 recursing.
1050
1051 To implement the dfun we must generate code for the superclass C [a],
1052 which we had better not get by superclass selection from the supplied
1053 argument:
1054        dfun :: forall a. D [a] -> D [a]
1055        dfun = \d::D [a] -> MkD (scsel d) ..
1056
1057 Otherwise if we later encounter a situation where
1058 we have a [Wanted] dw::D [a] we might solve it thus:
1059      dw := dfun dw
1060 Which is all fine except that now ** the superclass C is bottom **!
1061
1062       THE SOLUTION
1063
1064 Our solution to this problem "silent superclass arguments".  We pass
1065 to each dfun some ``silent superclass arguments’’, which are the
1066 immediate superclasses of the dictionary we are trying to
1067 construct. In our example:
1068        dfun :: forall a. C [a] -> D [a] -> D [a]
1069        dfun = \(dc::C [a]) (dd::D [a]) -> DOrd dc ...
1070 Notice the extra (dc :: C [a]) argument compared to the previous version.
1071
1072 This gives us:
1073
1074      -----------------------------------------------------------
1075      DFun Superclass Invariant
1076      ~~~~~~~~~~~~~~~~~~~~~~~~
1077      In the body of a DFun, every superclass argument to the
1078      returned dictionary is
1079        either   * one of the arguments of the DFun,
1080        or       * constant, bound at top level
1081      -----------------------------------------------------------
1082
1083 This net effect is that it is safe to treat a dfun application as
1084 wrapping a dictionary constructor around its arguments (in particular,
1085 a dfun never picks superclasses from the arguments under the
1086 dictionary constructor). No superclass is hidden inside a dfun
1087 application.
1088
1089 The extra arguments required to satisfy the DFun Superclass Invariant
1090 always come first, and are called the "silent" arguments.  You can
1091 find out how many silent arguments there are using Id.dfunNSilent;
1092 and then you can just drop that number of arguments to see the ones
1093 that were in the original instance declaration.
1094
1095 DFun types are built (only) by MkId.mkDictFunId, so that is where we
1096 decide what silent arguments are to be added.
1097
1098 In our example, if we had  [Wanted] dw :: D [a] we would get via the instance:
1099     dw := dfun d1 d2
1100     [Wanted] (d1 :: C [a])
1101     [Wanted] (d2 :: D [a])
1102
1103 And now, though we *can* solve: 
1104      d2 := dw
1105 That's fine; and we solve d1:C[a] separately.
1106
1107 Test case SCLoop tests this fix.
1108
1109 Note [SPECIALISE instance pragmas]
1110 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1111 Consider
1112
1113    instance (Ix a, Ix b) => Ix (a,b) where
1114      {-# SPECIALISE instance Ix (Int,Int) #-}
1115      range (x,y) = ...
1116
1117 We make a specialised version of the dictionary function, AND
1118 specialised versions of each *method*.  Thus we should generate
1119 something like this:
1120
1121   $dfIxPair :: (Ix a, Ix b) => Ix (a,b)
1122   {-# DFUN [$crangePair, ...] #-}
1123   {-# SPECIALISE $dfIxPair :: Ix (Int,Int) #-}
1124   $dfIxPair da db = Ix ($crangePair da db) (...other methods...)
1125
1126   $crange :: (Ix a, Ix b) -> ((a,b),(a,b)) -> [(a,b)]
1127   {-# SPECIALISE $crange :: ((Int,Int),(Int,Int)) -> [(Int,Int)] #-}
1128   $crange da db = <blah>
1129
1130 The SPECIALISE pragmas are acted upon by the desugarer, which generate
1131
1132   dii :: Ix Int
1133   dii = ...
1134
1135   $s$dfIxPair :: Ix ((Int,Int),(Int,Int))
1136   {-# DFUN [$crangePair di di, ...] #-}
1137   $s$dfIxPair = Ix ($crangePair di di) (...)
1138
1139   {-# RULE forall (d1,d2:Ix Int). $dfIxPair Int Int d1 d2 = $s$dfIxPair #-}
1140
1141   $s$crangePair :: ((Int,Int),(Int,Int)) -> [(Int,Int)]
1142   $c$crangePair = ...specialised RHS of $crangePair...
1143
1144   {-# RULE forall (d1,d2:Ix Int). $crangePair Int Int d1 d2 = $s$crangePair #-}
1145  
1146 Note that
1147
1148   * The specialised dictionary $s$dfIxPair is very much needed, in case we
1149     call a function that takes a dictionary, but in a context where the 
1150     specialised dictionary can be used.  See Trac #7797.
1151
1152   * The ClassOp rule for 'range' works equally well on $s$dfIxPair, because
1153     it still has a DFunUnfolding.  See Note [ClassOp/DFun selection]
1154
1155   * A call (range ($dfIxPair Int Int d1 d2)) might simplify two ways:
1156        --> {ClassOp rule for range}     $crangePair Int Int d1 d2
1157        --> {SPEC rule for $crangePair}  $s$crangePair
1158     or thus:
1159        --> {SPEC rule for $dfIxPair}    range $s$dfIxPair
1160        --> {ClassOpRule for range}      $s$crangePair
1161     It doesn't matter which way.
1162
1163   * We want to specialise the RHS of both $dfIxPair and $crangePair,
1164     but the SAME HsWrapper will do for both!  We can call tcSpecPrag
1165     just once, and pass the result (in spec_inst_info) to tcInstanceMethods.
1166
1167
1168 \begin{code}
1169 tcSpecInst :: Id -> Sig Name -> TcM TcSpecPrag
1170 tcSpecInst dfun_id prag@(SpecInstSig hs_ty)
1171   = addErrCtxt (spec_ctxt prag) $
1172     do  { let name = idName dfun_id
1173         ; (tyvars, theta, clas, tys) <- tcHsInstHead SpecInstCtxt hs_ty
1174         ; let (_, spec_dfun_ty) = mkDictFunTy tyvars theta clas tys
1175
1176         ; co_fn <- tcSubType (SpecPragOrigin name) SpecInstCtxt
1177                              (idType dfun_id) spec_dfun_ty
1178         ; return (SpecPrag dfun_id co_fn defaultInlinePragma) }
1179   where
1180     spec_ctxt prag = hang (ptext (sLit "In the SPECIALISE pragma")) 2 (ppr prag)
1181
1182 tcSpecInst _  _ = panic "tcSpecInst"
1183 \end{code}
1184
1185 %************************************************************************
1186 %*                                                                      *
1187       Type-checking an instance method
1188 %*                                                                      *
1189 %************************************************************************
1190
1191 tcInstanceMethod
1192 - Make the method bindings, as a [(NonRec, HsBinds)], one per method
1193 - Remembering to use fresh Name (the instance method Name) as the binder
1194 - Bring the instance method Ids into scope, for the benefit of tcInstSig
1195 - Use sig_fn mapping instance method Name -> instance tyvars
1196 - Ditto prag_fn
1197 - Use tcValBinds to do the checking
1198
1199 \begin{code}
1200 tcInstanceMethods :: DFunId -> Class -> [TcTyVar]
1201                   -> [EvVar]
1202                   -> [TcType]
1203                   -> ([Located TcSpecPrag], PragFun)
1204                   -> [(Id, DefMeth)]
1205                   -> InstBindings Name
1206                   -> TcM ([Id], [LHsBind Id])
1207         -- The returned inst_meth_ids all have types starting
1208         --      forall tvs. theta => ...
1209 tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
1210                   (spec_inst_prags, prag_fn)
1211                   op_items (InstBindings { ib_binds = binds
1212                                          , ib_pragmas = sigs
1213                                          , ib_extensions = exts
1214                                          , ib_standalone_deriving
1215                                               = standalone_deriv })
1216   = do { traceTc "tcInstMeth" (ppr sigs $$ ppr binds)
1217        ; let hs_sig_fn = mkHsSigFun sigs
1218        ; checkMinimalDefinition
1219        ; set_exts exts $ mapAndUnzipM (tc_item hs_sig_fn) op_items }
1220   where
1221     set_exts :: [ExtensionFlag] -> TcM a -> TcM a
1222     set_exts es thing = foldr setXOptM thing es
1223     
1224     ----------------------
1225     tc_item :: HsSigFun -> (Id, DefMeth) -> TcM (Id, LHsBind Id)
1226     tc_item sig_fn (sel_id, dm_info)
1227       = case findMethodBind (idName sel_id) binds of
1228             Just (user_bind, bndr_loc) 
1229                      -> tc_body sig_fn sel_id standalone_deriv user_bind bndr_loc
1230             Nothing  -> do { traceTc "tc_def" (ppr sel_id)
1231                            ; tc_default sig_fn sel_id dm_info }
1232
1233     ----------------------
1234     tc_body :: HsSigFun -> Id -> Bool -> LHsBind Name
1235             -> SrcSpan -> TcM (TcId, LHsBind Id)
1236     tc_body sig_fn sel_id generated_code rn_bind bndr_loc
1237       = add_meth_ctxt sel_id generated_code rn_bind $
1238         do { traceTc "tc_item" (ppr sel_id <+> ppr (idType sel_id))
1239            ; (meth_id, local_meth_sig) <- setSrcSpan bndr_loc $
1240                                           mkMethIds sig_fn clas tyvars dfun_ev_vars
1241                                                     inst_tys sel_id
1242            ; let prags = prag_fn (idName sel_id)
1243            ; meth_id1 <- addInlinePrags meth_id prags
1244            ; spec_prags <- tcSpecPrags meth_id1 prags
1245            ; bind <- tcInstanceMethodBody InstSkol
1246                           tyvars dfun_ev_vars
1247                           meth_id1 local_meth_sig
1248                           (mk_meth_spec_prags meth_id1 spec_prags)
1249                           rn_bind
1250            ; return (meth_id1, bind) }
1251
1252     ----------------------
1253     tc_default :: HsSigFun -> Id -> DefMeth -> TcM (TcId, LHsBind Id)
1254
1255     tc_default sig_fn sel_id (GenDefMeth dm_name)
1256       = do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id dm_name
1257            ; tc_body sig_fn sel_id False {- Not generated code? -} 
1258                      meth_bind inst_loc }
1259
1260     tc_default sig_fn sel_id NoDefMeth     -- No default method at all
1261       = do { traceTc "tc_def: warn" (ppr sel_id)
1262            ; (meth_id, _) <- mkMethIds sig_fn clas tyvars dfun_ev_vars
1263                                        inst_tys sel_id
1264            ; dflags <- getDynFlags
1265            ; return (meth_id,
1266                      mkVarBind meth_id $
1267                        mkLHsWrap lam_wrapper (error_rhs dflags)) }
1268       where
1269         error_rhs dflags = L inst_loc $ HsApp error_fun (error_msg dflags)
1270         error_fun    = L inst_loc $ wrapId (WpTyApp meth_tau) nO_METHOD_BINDING_ERROR_ID
1271         error_msg dflags = L inst_loc (HsLit (HsStringPrim (unsafeMkByteString (error_string dflags))))
1272         meth_tau     = funResultTy (applyTys (idType sel_id) inst_tys)
1273         error_string dflags = showSDoc dflags (hcat [ppr inst_loc, text "|", ppr sel_id ])
1274         lam_wrapper  = mkWpTyLams tyvars <.> mkWpLams dfun_ev_vars
1275
1276     tc_default sig_fn sel_id (DefMeth dm_name) -- A polymorphic default method
1277       = do {   -- Build the typechecked version directly,
1278                  -- without calling typecheck_method;
1279                  -- see Note [Default methods in instances]
1280                  -- Generate   /\as.\ds. let self = df as ds
1281                  --                      in $dm inst_tys self
1282                  -- The 'let' is necessary only because HsSyn doesn't allow
1283                  -- you to apply a function to a dictionary *expression*.
1284
1285            ; self_dict <- newDict clas inst_tys
1286            ; let self_ev_bind = EvBind self_dict
1287                                 (EvDFunApp dfun_id (mkTyVarTys tyvars) (map EvId dfun_ev_vars))
1288
1289            ; (meth_id, local_meth_sig) <- mkMethIds sig_fn clas tyvars dfun_ev_vars
1290                                                     inst_tys sel_id
1291            ; dm_id <- tcLookupId dm_name
1292            ; let dm_inline_prag = idInlinePragma dm_id
1293                  rhs = HsWrap (mkWpEvVarApps [self_dict] <.> mkWpTyApps inst_tys) $
1294                        HsVar dm_id
1295
1296                  local_meth_id = sig_id local_meth_sig
1297                  meth_bind = mkVarBind local_meth_id (L inst_loc rhs)
1298                  meth_id1 = meth_id `setInlinePragma` dm_inline_prag
1299                         -- Copy the inline pragma (if any) from the default
1300                         -- method to this version. Note [INLINE and default methods]
1301
1302                   
1303                  export = ABE { abe_wrap = idHsWrapper, abe_poly = meth_id1
1304                               , abe_mono = local_meth_id
1305                               , abe_prags = mk_meth_spec_prags meth_id1 [] }
1306                  bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars
1307                                  , abs_exports = [export]
1308                                  , abs_ev_binds = EvBinds (unitBag self_ev_bind)
1309                                  , abs_binds    = unitBag meth_bind }
1310              -- Default methods in an instance declaration can't have their own
1311              -- INLINE or SPECIALISE pragmas. It'd be possible to allow them, but
1312              -- currently they are rejected with
1313              --           "INLINE pragma lacks an accompanying binding"
1314
1315            ; return (meth_id1, L inst_loc bind) }
1316
1317     ----------------------
1318     mk_meth_spec_prags :: Id -> [LTcSpecPrag] -> TcSpecPrags
1319         -- Adapt the 'SPECIALISE instance' pragmas to work for this method Id
1320         -- There are two sources:
1321         --   * spec_prags_for_me: {-# SPECIALISE op :: <blah> #-}
1322         --   * spec_prags_from_inst: derived from {-# SPECIALISE instance :: <blah> #-}
1323         --     These ones have the dfun inside, but [perhaps surprisingly]
1324         --     the correct wrapper.
1325     mk_meth_spec_prags meth_id spec_prags_for_me
1326       = SpecPrags (spec_prags_for_me ++ spec_prags_from_inst)
1327       where
1328         spec_prags_from_inst
1329            | isInlinePragma (idInlinePragma meth_id)
1330            = []  -- Do not inherit SPECIALISE from the instance if the
1331                  -- method is marked INLINE, because then it'll be inlined
1332                  -- and the specialisation would do nothing. (Indeed it'll provoke
1333                  -- a warning from the desugarer
1334            | otherwise 
1335            = [ L inst_loc (SpecPrag meth_id wrap inl)
1336              | L inst_loc (SpecPrag _ wrap inl) <- spec_inst_prags]
1337
1338     inst_loc = getSrcSpan dfun_id
1339
1340         -- For instance decls that come from standalone deriving clauses
1341         -- we want to print out the full source code if there's an error
1342         -- because otherwise the user won't see the code at all
1343     add_meth_ctxt sel_id generated_code rn_bind thing
1344       | generated_code = addLandmarkErrCtxt (derivBindCtxt sel_id clas inst_tys rn_bind) thing
1345       | otherwise      = thing
1346
1347     ----------------------
1348
1349     -- check if one of the minimal complete definitions is satisfied
1350     checkMinimalDefinition
1351       = whenIsJust (isUnsatisfied methodExists (classMinimalDef clas)) $
1352           warnUnsatisifiedMinimalDefinition
1353       where
1354       methodExists meth = isJust (findMethodBind meth binds)
1355
1356 mkGenericDefMethBind :: Class -> [Type] -> Id -> Name -> TcM (LHsBind Name)
1357 mkGenericDefMethBind clas inst_tys sel_id dm_name
1358   =     -- A generic default method
1359         -- If the method is defined generically, we only have to call the
1360         -- dm_name.
1361     do  { dflags <- getDynFlags
1362         ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body"
1363                    (vcat [ppr clas <+> ppr inst_tys,
1364                           nest 2 (ppr sel_id <+> equals <+> ppr rhs)]))
1365
1366         ; return (noLoc $ mkTopFunBind Generated (noLoc (idName sel_id))
1367                                        [mkSimpleMatch [] rhs]) }
1368   where
1369     rhs = nlHsVar dm_name
1370
1371 ----------------------
1372 wrapId :: HsWrapper -> id -> HsExpr id
1373 wrapId wrapper id = mkHsWrap wrapper (HsVar id)
1374
1375 derivBindCtxt :: Id -> Class -> [Type ] -> LHsBind Name -> SDoc
1376 derivBindCtxt sel_id clas tys _bind
1377    = vcat [ ptext (sLit "When typechecking the code for ") <+> quotes (ppr sel_id)
1378           , nest 2 (ptext (sLit "in a standalone derived instance for")
1379                     <+> quotes (pprClassPred clas tys) <> colon)
1380           , nest 2 $ ptext (sLit "To see the code I am typechecking, use -ddump-deriv") ]
1381
1382 warnMissingMethodOrAT :: String -> Name -> TcM ()
1383 warnMissingMethodOrAT what name
1384   = do { warn <- woptM Opt_WarnMissingMethods
1385        ; traceTc "warn" (ppr name <+> ppr warn <+> ppr (not (startsWithUnderscore (getOccName name))))
1386        ; warnTc (warn  -- Warn only if -fwarn-missing-methods
1387                  && not (startsWithUnderscore (getOccName name)))
1388                                         -- Don't warn about _foo methods
1389                 (ptext (sLit "No explicit") <+> text what <+> ptext (sLit "or default declaration for")
1390                  <+> quotes (ppr name)) }
1391
1392 warnUnsatisifiedMinimalDefinition :: ClassMinimalDef -> TcM ()
1393 warnUnsatisifiedMinimalDefinition mindef
1394   = do { warn <- woptM Opt_WarnMissingMethods
1395        ; warnTc warn message
1396        }
1397   where
1398     message = vcat [ptext (sLit "No explicit implementation for")
1399                    ,nest 2 $ pprBooleanFormulaNice mindef
1400                    ]
1401 \end{code}
1402
1403 Note [Export helper functions]
1404 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1405 We arrange to export the "helper functions" of an instance declaration,
1406 so that they are not subject to preInlineUnconditionally, even if their
1407 RHS is trivial.  Reason: they are mentioned in the DFunUnfolding of
1408 the dict fun as Ids, not as CoreExprs, so we can't substitute a
1409 non-variable for them.
1410
1411 We could change this by making DFunUnfoldings have CoreExprs, but it
1412 seems a bit simpler this way.
1413
1414 Note [Default methods in instances]
1415 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1416 Consider this
1417
1418    class Baz v x where
1419       foo :: x -> x
1420       foo y = <blah>
1421
1422    instance Baz Int Int
1423
1424 From the class decl we get
1425
1426    $dmfoo :: forall v x. Baz v x => x -> x
1427    $dmfoo y = <blah>
1428
1429 Notice that the type is ambiguous.  That's fine, though. The instance
1430 decl generates
1431
1432    $dBazIntInt = MkBaz fooIntInt
1433    fooIntInt = $dmfoo Int Int $dBazIntInt
1434
1435 BUT this does mean we must generate the dictionary translation of
1436 fooIntInt directly, rather than generating source-code and
1437 type-checking it.  That was the bug in Trac #1061. In any case it's
1438 less work to generate the translated version!
1439
1440 Note [INLINE and default methods]
1441 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1442 Default methods need special case.  They are supposed to behave rather like
1443 macros.  For exmample
1444
1445   class Foo a where
1446     op1, op2 :: Bool -> a -> a
1447
1448     {-# INLINE op1 #-}
1449     op1 b x = op2 (not b) x
1450
1451   instance Foo Int where
1452     -- op1 via default method
1453     op2 b x = <blah>
1454
1455 The instance declaration should behave
1456
1457    just as if 'op1' had been defined with the
1458    code, and INLINE pragma, from its original
1459    definition.
1460
1461 That is, just as if you'd written
1462
1463   instance Foo Int where
1464     op2 b x = <blah>
1465
1466     {-# INLINE op1 #-}
1467     op1 b x = op2 (not b) x
1468
1469 So for the above example we generate:
1470
1471   {-# INLINE $dmop1 #-}
1472   -- $dmop1 has an InlineCompulsory unfolding
1473   $dmop1 d b x = op2 d (not b) x
1474
1475   $fFooInt = MkD $cop1 $cop2
1476
1477   {-# INLINE $cop1 #-}
1478   $cop1 = $dmop1 $fFooInt
1479
1480   $cop2 = <blah>
1481
1482 Note carefullly:
1483
1484 * We *copy* any INLINE pragma from the default method $dmop1 to the
1485   instance $cop1.  Otherwise we'll just inline the former in the
1486   latter and stop, which isn't what the user expected
1487
1488 * Regardless of its pragma, we give the default method an
1489   unfolding with an InlineCompulsory source. That means
1490   that it'll be inlined at every use site, notably in
1491   each instance declaration, such as $cop1.  This inlining
1492   must happen even though
1493     a) $dmop1 is not saturated in $cop1
1494     b) $cop1 itself has an INLINE pragma
1495
1496   It's vital that $dmop1 *is* inlined in this way, to allow the mutual
1497   recursion between $fooInt and $cop1 to be broken
1498
1499 * To communicate the need for an InlineCompulsory to the desugarer
1500   (which makes the Unfoldings), we use the IsDefaultMethod constructor
1501   in TcSpecPrags.
1502
1503
1504 %************************************************************************
1505 %*                                                                      *
1506 \subsection{Error messages}
1507 %*                                                                      *
1508 %************************************************************************
1509
1510 \begin{code}
1511 instDeclCtxt1 :: LHsType Name -> SDoc
1512 instDeclCtxt1 hs_inst_ty
1513   = inst_decl_ctxt (case unLoc hs_inst_ty of
1514                         HsForAllTy _ _ _ (L _ ty') -> ppr ty'
1515                         _                          -> ppr hs_inst_ty)     -- Don't expect this
1516 instDeclCtxt2 :: Type -> SDoc
1517 instDeclCtxt2 dfun_ty
1518   = inst_decl_ctxt (ppr (mkClassPred cls tys))
1519   where
1520     (_,_,cls,tys) = tcSplitDFunTy dfun_ty
1521
1522 inst_decl_ctxt :: SDoc -> SDoc
1523 inst_decl_ctxt doc = hang (ptext (sLit "In the instance declaration for"))
1524                         2 (quotes doc)
1525
1526 badBootFamInstDeclErr :: SDoc
1527 badBootFamInstDeclErr
1528   = ptext (sLit "Illegal family instance in hs-boot file")
1529
1530 notFamily :: TyCon -> SDoc
1531 notFamily tycon
1532   = vcat [ ptext (sLit "Illegal family instance for") <+> quotes (ppr tycon)
1533          , nest 2 $ parens (ppr tycon <+> ptext (sLit "is not an indexed type family"))]
1534
1535 tooFewParmsErr :: Arity -> SDoc
1536 tooFewParmsErr arity
1537   = ptext (sLit "Family instance has too few parameters; expected") <+>
1538     ppr arity
1539
1540 assocInClassErr :: Located Name -> SDoc
1541 assocInClassErr name
1542  = ptext (sLit "Associated type") <+> quotes (ppr name) <+>
1543    ptext (sLit "must be inside a class instance")
1544
1545 badFamInstDecl :: Located Name -> SDoc
1546 badFamInstDecl tc_name
1547   = vcat [ ptext (sLit "Illegal family instance for") <+>
1548            quotes (ppr tc_name)
1549          , nest 2 (parens $ ptext (sLit "Use TypeFamilies to allow indexed type families")) ]
1550
1551 notOpenFamily :: TyCon -> SDoc
1552 notOpenFamily tc
1553   = ptext (sLit "Illegal instance for closed family") <+> quotes (ppr tc)
1554 \end{code}