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