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