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