77522c55ab508da38ec38b654d6107ee0cebdfab
[ghc.git] / compiler / typecheck / TcInstDcls.hs
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
9 {-# LANGUAGE CPP #-}
10 {-# LANGUAGE FlexibleContexts #-}
11 {-# LANGUAGE TypeFamilies #-}
12
13 module TcInstDcls ( tcInstDecls1, tcInstDeclsDeriv, tcInstDecls2 ) where
14
15 #include "HsVersions.h"
16
17 import GhcPrelude
18
19 import HsSyn
20 import TcBinds
21 import TcTyClsDecls
22 import TcClassDcl( tcClassDecl2, tcATDefault,
23 HsSigFun, mkHsSigFun,
24 findMethodBind, instantiateMethod )
25 import TcSigs
26 import TcRnMonad
27 import TcValidity
28 import TcHsSyn ( zonkTyBndrsX, emptyZonkEnv
29 , zonkTcTypeToTypes, zonkTcTypeToType )
30 import TcMType
31 import TcType
32 import BuildTyCl
33 import Inst
34 import InstEnv
35 import FamInst
36 import FamInstEnv
37 import TcDeriv
38 import TcEnv
39 import TcHsType
40 import TcUnify
41 import CoreSyn ( Expr(..), mkApps, mkVarApps, mkLams )
42 import MkCore ( nO_METHOD_BINDING_ERROR_ID )
43 import CoreUnfold ( mkInlineUnfoldingWithArity, mkDFunUnfolding )
44 import Type
45 import TcEvidence
46 import TyCon
47 import CoAxiom
48 import DataCon
49 import ConLike
50 import Class
51 import Var
52 import VarEnv
53 import VarSet
54 import PrelNames ( typeableClassName, genericClassNames
55 , knownNatClassName, knownSymbolClassName )
56 import Bag
57 import BasicTypes
58 import DynFlags
59 import ErrUtils
60 import FastString
61 import Id
62 import MkId
63 import Name
64 import NameSet
65 import Outputable
66 import SrcLoc
67 import Util
68 import BooleanFormula ( isUnsatisfied, pprBooleanFormulaNice )
69 import qualified GHC.LanguageExtensions as LangExt
70
71 import Control.Monad
72 import Maybes
73
74
75 {-
76 Typechecking instance declarations is done in two passes. The first
77 pass, made by @tcInstDecls1@, collects information to be used in the
78 second pass.
79
80 This pre-processed info includes the as-yet-unprocessed bindings
81 inside the instance declaration. These are type-checked in the second
82 pass, when the class-instance envs and GVE contain all the info from
83 all the instance and value decls. Indeed that's the reason we need
84 two passes over the instance decls.
85
86
87 Note [How instance declarations are translated]
88 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
89 Here is how we translate instance declarations into Core
90
91 Running example:
92 class C a where
93 op1, op2 :: Ix b => a -> b -> b
94 op2 = <dm-rhs>
95
96 instance C a => C [a]
97 {-# INLINE [2] op1 #-}
98 op1 = <rhs>
99 ===>
100 -- Method selectors
101 op1,op2 :: forall a. C a => forall b. Ix b => a -> b -> b
102 op1 = ...
103 op2 = ...
104
105 -- Default methods get the 'self' dictionary as argument
106 -- so they can call other methods at the same type
107 -- Default methods get the same type as their method selector
108 $dmop2 :: forall a. C a => forall b. Ix b => a -> b -> b
109 $dmop2 = /\a. \(d:C a). /\b. \(d2: Ix b). <dm-rhs>
110 -- NB: type variables 'a' and 'b' are *both* in scope in <dm-rhs>
111 -- Note [Tricky type variable scoping]
112
113 -- A top-level definition for each instance method
114 -- Here op1_i, op2_i are the "instance method Ids"
115 -- The INLINE pragma comes from the user pragma
116 {-# INLINE [2] op1_i #-} -- From the instance decl bindings
117 op1_i, op2_i :: forall a. C a => forall b. Ix b => [a] -> b -> b
118 op1_i = /\a. \(d:C a).
119 let this :: C [a]
120 this = df_i a d
121 -- Note [Subtle interaction of recursion and overlap]
122
123 local_op1 :: forall b. Ix b => [a] -> b -> b
124 local_op1 = <rhs>
125 -- Source code; run the type checker on this
126 -- NB: Type variable 'a' (but not 'b') is in scope in <rhs>
127 -- Note [Tricky type variable scoping]
128
129 in local_op1 a d
130
131 op2_i = /\a \d:C a. $dmop2 [a] (df_i a d)
132
133 -- The dictionary function itself
134 {-# NOINLINE CONLIKE df_i #-} -- Never inline dictionary functions
135 df_i :: forall a. C a -> C [a]
136 df_i = /\a. \d:C a. MkC (op1_i a d) (op2_i a d)
137 -- But see Note [Default methods in instances]
138 -- We can't apply the type checker to the default-method call
139
140 -- Use a RULE to short-circuit applications of the class ops
141 {-# RULE "op1@C[a]" forall a, d:C a.
142 op1 [a] (df_i d) = op1_i a d #-}
143
144 Note [Instances and loop breakers]
145 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
146 * Note that df_i may be mutually recursive with both op1_i and op2_i.
147 It's crucial that df_i is not chosen as the loop breaker, even
148 though op1_i has a (user-specified) INLINE pragma.
149
150 * Instead the idea is to inline df_i into op1_i, which may then select
151 methods from the MkC record, and thereby break the recursion with
152 df_i, leaving a *self*-recursive op1_i. (If op1_i doesn't call op at
153 the same type, it won't mention df_i, so there won't be recursion in
154 the first place.)
155
156 * If op1_i is marked INLINE by the user there's a danger that we won't
157 inline df_i in it, and that in turn means that (since it'll be a
158 loop-breaker because df_i isn't), op1_i will ironically never be
159 inlined. But this is OK: the recursion breaking happens by way of
160 a RULE (the magic ClassOp rule above), and RULES work inside InlineRule
161 unfoldings. See Note [RULEs enabled in SimplGently] in SimplUtils
162
163 Note [ClassOp/DFun selection]
164 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
165 One thing we see a lot is stuff like
166 op2 (df d1 d2)
167 where 'op2' is a ClassOp and 'df' is DFun. Now, we could inline *both*
168 'op2' and 'df' to get
169 case (MkD ($cop1 d1 d2) ($cop2 d1 d2) ... of
170 MkD _ op2 _ _ _ -> op2
171 And that will reduce to ($cop2 d1 d2) which is what we wanted.
172
173 But it's tricky to make this work in practice, because it requires us to
174 inline both 'op2' and 'df'. But neither is keen to inline without having
175 seen the other's result; and it's very easy to get code bloat (from the
176 big intermediate) if you inline a bit too much.
177
178 Instead we use a cunning trick.
179 * We arrange that 'df' and 'op2' NEVER inline.
180
181 * We arrange that 'df' is ALWAYS defined in the sylised form
182 df d1 d2 = MkD ($cop1 d1 d2) ($cop2 d1 d2) ...
183
184 * We give 'df' a magical unfolding (DFunUnfolding [$cop1, $cop2, ..])
185 that lists its methods.
186
187 * We make CoreUnfold.exprIsConApp_maybe spot a DFunUnfolding and return
188 a suitable constructor application -- inlining df "on the fly" as it
189 were.
190
191 * ClassOp rules: We give the ClassOp 'op2' a BuiltinRule that
192 extracts the right piece iff its argument satisfies
193 exprIsConApp_maybe. This is done in MkId mkDictSelId
194
195 * We make 'df' CONLIKE, so that shared uses still match; eg
196 let d = df d1 d2
197 in ...(op2 d)...(op1 d)...
198
199 Note [Single-method classes]
200 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
201 If the class has just one method (or, more accurately, just one element
202 of {superclasses + methods}), then we use a different strategy.
203
204 class C a where op :: a -> a
205 instance C a => C [a] where op = <blah>
206
207 We translate the class decl into a newtype, which just gives a
208 top-level axiom. The "constructor" MkC expands to a cast, as does the
209 class-op selector.
210
211 axiom Co:C a :: C a ~ (a->a)
212
213 op :: forall a. C a -> (a -> a)
214 op a d = d |> (Co:C a)
215
216 MkC :: forall a. (a->a) -> C a
217 MkC = /\a.\op. op |> (sym Co:C a)
218
219 The clever RULE stuff doesn't work now, because ($df a d) isn't
220 a constructor application, so exprIsConApp_maybe won't return
221 Just <blah>.
222
223 Instead, we simply rely on the fact that casts are cheap:
224
225 $df :: forall a. C a => C [a]
226 {-# INLINE df #-} -- NB: INLINE this
227 $df = /\a. \d. MkC [a] ($cop_list a d)
228 = $cop_list |> forall a. C a -> (sym (Co:C [a]))
229
230 $cop_list :: forall a. C a => [a] -> [a]
231 $cop_list = <blah>
232
233 So if we see
234 (op ($df a d))
235 we'll inline 'op' and '$df', since both are simply casts, and
236 good things happen.
237
238 Why do we use this different strategy? Because otherwise we
239 end up with non-inlined dictionaries that look like
240 $df = $cop |> blah
241 which adds an extra indirection to every use, which seems stupid. See
242 Trac #4138 for an example (although the regression reported there
243 wasn't due to the indirection).
244
245 There is an awkward wrinkle though: we want to be very
246 careful when we have
247 instance C a => C [a] where
248 {-# INLINE op #-}
249 op = ...
250 then we'll get an INLINE pragma on $cop_list but it's important that
251 $cop_list only inlines when it's applied to *two* arguments (the
252 dictionary and the list argument). So we must not eta-expand $df
253 above. We ensure that this doesn't happen by putting an INLINE
254 pragma on the dfun itself; after all, it ends up being just a cast.
255
256 There is one more dark corner to the INLINE story, even more deeply
257 buried. Consider this (Trac #3772):
258
259 class DeepSeq a => C a where
260 gen :: Int -> a
261
262 instance C a => C [a] where
263 gen n = ...
264
265 class DeepSeq a where
266 deepSeq :: a -> b -> b
267
268 instance DeepSeq a => DeepSeq [a] where
269 {-# INLINE deepSeq #-}
270 deepSeq xs b = foldr deepSeq b xs
271
272 That gives rise to these defns:
273
274 $cdeepSeq :: DeepSeq a -> [a] -> b -> b
275 -- User INLINE( 3 args )!
276 $cdeepSeq a (d:DS a) b (x:[a]) (y:b) = ...
277
278 $fDeepSeq[] :: DeepSeq a -> DeepSeq [a]
279 -- DFun (with auto INLINE pragma)
280 $fDeepSeq[] a d = $cdeepSeq a d |> blah
281
282 $cp1 a d :: C a => DeepSep [a]
283 -- We don't want to eta-expand this, lest
284 -- $cdeepSeq gets inlined in it!
285 $cp1 a d = $fDeepSep[] a (scsel a d)
286
287 $fC[] :: C a => C [a]
288 -- Ordinary DFun
289 $fC[] a d = MkC ($cp1 a d) ($cgen a d)
290
291 Here $cp1 is the code that generates the superclass for C [a]. The
292 issue is this: we must not eta-expand $cp1 either, or else $fDeepSeq[]
293 and then $cdeepSeq will inline there, which is definitely wrong. Like
294 on the dfun, we solve this by adding an INLINE pragma to $cp1.
295
296 Note [Subtle interaction of recursion and overlap]
297 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
298 Consider this
299 class C a where { op1,op2 :: a -> a }
300 instance C a => C [a] where
301 op1 x = op2 x ++ op2 x
302 op2 x = ...
303 instance C [Int] where
304 ...
305
306 When type-checking the C [a] instance, we need a C [a] dictionary (for
307 the call of op2). If we look up in the instance environment, we find
308 an overlap. And in *general* the right thing is to complain (see Note
309 [Overlapping instances] in InstEnv). But in *this* case it's wrong to
310 complain, because we just want to delegate to the op2 of this same
311 instance.
312
313 Why is this justified? Because we generate a (C [a]) constraint in
314 a context in which 'a' cannot be instantiated to anything that matches
315 other overlapping instances, or else we would not be executing this
316 version of op1 in the first place.
317
318 It might even be a bit disguised:
319
320 nullFail :: C [a] => [a] -> [a]
321 nullFail x = op2 x ++ op2 x
322
323 instance C a => C [a] where
324 op1 x = nullFail x
325
326 Precisely this is used in package 'regex-base', module Context.hs.
327 See the overlapping instances for RegexContext, and the fact that they
328 call 'nullFail' just like the example above. The DoCon package also
329 does the same thing; it shows up in module Fraction.hs.
330
331 Conclusion: when typechecking the methods in a C [a] instance, we want to
332 treat the 'a' as an *existential* type variable, in the sense described
333 by Note [Binding when looking up instances]. That is why isOverlappableTyVar
334 responds True to an InstSkol, which is the kind of skolem we use in
335 tcInstDecl2.
336
337
338 Note [Tricky type variable scoping]
339 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
340 In our example
341 class C a where
342 op1, op2 :: Ix b => a -> b -> b
343 op2 = <dm-rhs>
344
345 instance C a => C [a]
346 {-# INLINE [2] op1 #-}
347 op1 = <rhs>
348
349 note that 'a' and 'b' are *both* in scope in <dm-rhs>, but only 'a' is
350 in scope in <rhs>. In particular, we must make sure that 'b' is in
351 scope when typechecking <dm-rhs>. This is achieved by subFunTys,
352 which brings appropriate tyvars into scope. This happens for both
353 <dm-rhs> and for <rhs>, but that doesn't matter: the *renamer* will have
354 complained if 'b' is mentioned in <rhs>.
355
356
357
358 ************************************************************************
359 * *
360 \subsection{Extracting instance decls}
361 * *
362 ************************************************************************
363
364 Gather up the instance declarations from their various sources
365 -}
366
367 tcInstDecls1 -- Deal with both source-code and imported instance decls
368 :: [LInstDecl GhcRn] -- Source code instance decls
369 -> TcM (TcGblEnv, -- The full inst env
370 [InstInfo GhcRn], -- Source-code instance decls to process;
371 -- contains all dfuns for this module
372 [DerivInfo]) -- From data family instances
373
374 tcInstDecls1 inst_decls
375 = do { -- Do class and family instance declarations
376 ; stuff <- mapAndRecoverM tcLocalInstDecl inst_decls
377
378 ; let (local_infos_s, fam_insts_s, datafam_deriv_infos) = unzip3 stuff
379 fam_insts = concat fam_insts_s
380 local_infos = concat local_infos_s
381
382 ; gbl_env <- addClsInsts local_infos $
383 addFamInsts fam_insts $
384 getGblEnv
385
386 ; return ( gbl_env
387 , local_infos
388 , concat datafam_deriv_infos ) }
389
390 -- | Use DerivInfo for data family instances (produced by tcInstDecls1),
391 -- datatype declarations (TyClDecl), and standalone deriving declarations
392 -- (DerivDecl) to check and process all derived class instances.
393 tcInstDeclsDeriv
394 :: [DerivInfo]
395 -> [LTyClDecl GhcRn]
396 -> [LDerivDecl GhcRn]
397 -> TcM (TcGblEnv, [InstInfo GhcRn], HsValBinds GhcRn)
398 tcInstDeclsDeriv datafam_deriv_infos tyclds derivds
399 = do th_stage <- getStage -- See Note [Deriving inside TH brackets]
400 if isBrackStage th_stage
401 then do { gbl_env <- getGblEnv
402 ; return (gbl_env, bagToList emptyBag, emptyValBindsOut) }
403 else do { data_deriv_infos <- mkDerivInfos tyclds
404 ; let deriv_infos = datafam_deriv_infos ++ data_deriv_infos
405 ; (tcg_env, info_bag, valbinds) <- tcDeriving deriv_infos derivds
406 ; return (tcg_env, bagToList info_bag, valbinds) }
407
408 addClsInsts :: [InstInfo GhcRn] -> TcM a -> TcM a
409 addClsInsts infos thing_inside
410 = tcExtendLocalInstEnv (map iSpec infos) thing_inside
411
412 addFamInsts :: [FamInst] -> TcM a -> TcM a
413 -- Extend (a) the family instance envt
414 -- (b) the type envt with stuff from data type decls
415 addFamInsts fam_insts thing_inside
416 = tcExtendLocalFamInstEnv fam_insts $
417 tcExtendGlobalEnv axioms $
418 tcExtendTyConEnv data_rep_tycons $
419 do { traceTc "addFamInsts" (pprFamInsts fam_insts)
420 ; tcg_env <- tcAddImplicits data_rep_tycons
421 -- Does not add its axiom; that comes from
422 -- adding the 'axioms' above
423 ; setGblEnv tcg_env thing_inside }
424 where
425 axioms = map (ACoAxiom . toBranchedAxiom . famInstAxiom) fam_insts
426 data_rep_tycons = famInstsRepTyCons fam_insts
427 -- The representation tycons for 'data instances' declarations
428
429 {-
430 Note [Deriving inside TH brackets]
431 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
432 Given a declaration bracket
433 [d| data T = A | B deriving( Show ) |]
434
435 there is really no point in generating the derived code for deriving(
436 Show) and then type-checking it. This will happen at the call site
437 anyway, and the type check should never fail! Moreover (Trac #6005)
438 the scoping of the generated code inside the bracket does not seem to
439 work out.
440
441 The easy solution is simply not to generate the derived instances at
442 all. (A less brutal solution would be to generate them with no
443 bindings.) This will become moot when we shift to the new TH plan, so
444 the brutal solution will do.
445 -}
446
447 tcLocalInstDecl :: LInstDecl GhcRn
448 -> TcM ([InstInfo GhcRn], [FamInst], [DerivInfo])
449 -- A source-file instance declaration
450 -- Type-check all the stuff before the "where"
451 --
452 -- We check for respectable instance type, and context
453 tcLocalInstDecl (L loc (TyFamInstD { tfid_inst = decl }))
454 = do { fam_inst <- tcTyFamInstDecl Nothing (L loc decl)
455 ; return ([], [fam_inst], []) }
456
457 tcLocalInstDecl (L loc (DataFamInstD { dfid_inst = decl }))
458 = do { (fam_inst, m_deriv_info) <- tcDataFamInstDecl Nothing (L loc decl)
459 ; return ([], [fam_inst], maybeToList m_deriv_info) }
460
461 tcLocalInstDecl (L loc (ClsInstD { cid_inst = decl }))
462 = do { (insts, fam_insts, deriv_infos) <- tcClsInstDecl (L loc decl)
463 ; return (insts, fam_insts, deriv_infos) }
464
465 tcClsInstDecl :: LClsInstDecl GhcRn
466 -> TcM ([InstInfo GhcRn], [FamInst], [DerivInfo])
467 -- The returned DerivInfos are for any associated data families
468 tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds
469 , cid_sigs = uprags, cid_tyfam_insts = ats
470 , cid_overlap_mode = overlap_mode
471 , cid_datafam_insts = adts }))
472 = setSrcSpan loc $
473 addErrCtxt (instDeclCtxt1 poly_ty) $
474 do { (tyvars, theta, clas, inst_tys) <- tcHsClsInstType InstDeclCtxt poly_ty
475 ; let mini_env = mkVarEnv (classTyVars clas `zip` inst_tys)
476 mini_subst = mkTvSubst (mkInScopeSet (mkVarSet tyvars)) mini_env
477 mb_info = Just (clas, tyvars, mini_env)
478
479 -- Next, process any associated types.
480 ; traceTc "tcLocalInstDecl" (ppr poly_ty)
481 ; tyfam_insts0 <- tcExtendTyVarEnv tyvars $
482 mapAndRecoverM (tcTyFamInstDecl mb_info) ats
483 ; datafam_stuff <- tcExtendTyVarEnv tyvars $
484 mapAndRecoverM (tcDataFamInstDecl mb_info) adts
485 ; let (datafam_insts, m_deriv_infos) = unzip datafam_stuff
486 deriv_infos = catMaybes m_deriv_infos
487
488 -- Check for missing associated types and build them
489 -- from their defaults (if available)
490 ; let defined_ats = mkNameSet (map (tyFamInstDeclName . unLoc) ats)
491 `unionNameSet`
492 mkNameSet (map (unLoc . feqn_tycon
493 . hsib_body
494 . dfid_eqn
495 . unLoc) adts)
496 ; tyfam_insts1 <- mapM (tcATDefault loc mini_subst defined_ats)
497 (classATItems clas)
498
499 -- Finally, construct the Core representation of the instance.
500 -- (This no longer includes the associated types.)
501 ; dfun_name <- newDFunName clas inst_tys (getLoc (hsSigType poly_ty))
502 -- Dfun location is that of instance *header*
503
504 ; ispec <- newClsInst (fmap unLoc overlap_mode) dfun_name tyvars theta
505 clas inst_tys
506
507 ; let inst_info = InstInfo { iSpec = ispec
508 , iBinds = InstBindings
509 { ib_binds = binds
510 , ib_tyvars = map Var.varName tyvars -- Scope over bindings
511 , ib_pragmas = uprags
512 , ib_extensions = []
513 , ib_derived = False } }
514
515 ; doClsInstErrorChecks inst_info
516
517 ; return ( [inst_info], tyfam_insts0 ++ concat tyfam_insts1 ++ datafam_insts
518 , deriv_infos ) }
519
520
521 doClsInstErrorChecks :: InstInfo GhcRn -> TcM ()
522 doClsInstErrorChecks inst_info
523 = do { traceTc "doClsInstErrorChecks" (ppr ispec)
524 ; dflags <- getDynFlags
525 ; is_boot <- tcIsHsBootOrSig
526
527 -- In hs-boot files there should be no bindings
528 ; failIfTc (is_boot && not no_binds) badBootDeclErr
529
530 -- If not in an hs-boot file, abstract classes cannot have
531 -- instances declared
532 ; failIfTc (not is_boot && isAbstractClass clas) abstractClassInstErr
533
534 -- Handwritten instances of any rejected
535 -- class is always forbidden
536 -- #12837
537 ; failIfTc (clas_nm `elem` rejectedClassNames) clas_err
538
539 -- Check for hand-written Generic instances (disallowed in Safe Haskell)
540 ; when (clas_nm `elem` genericClassNames) $
541 do { failIfTc (safeLanguageOn dflags) gen_inst_err
542 ; when (safeInferOn dflags) (recordUnsafeInfer emptyBag) }
543 }
544 where
545 ispec = iSpec inst_info
546 binds = iBinds inst_info
547 no_binds = isEmptyLHsBinds (ib_binds binds) && null (ib_pragmas binds)
548 clas_nm = is_cls_nm ispec
549 clas = is_cls ispec
550
551 gen_inst_err = hang (text ("Generic instances can only be "
552 ++ "derived in Safe Haskell.") $+$
553 text "Replace the following instance:")
554 2 (pprInstanceHdr ispec)
555
556 abstractClassInstErr =
557 text "Cannot define instance for abstract class" <+> quotes (ppr clas_nm)
558
559 -- Report an error or a warning for certain class instances.
560 -- If we are working on an .hs-boot file, we just report a warning,
561 -- and ignore the instance. We do this, to give users a chance to fix
562 -- their code.
563 rejectedClassNames = [ typeableClassName
564 , knownNatClassName
565 , knownSymbolClassName ]
566 clas_err = text "Class" <+> quotes (ppr clas_nm)
567 <+> text "does not support user-specified instances"
568
569 {-
570 ************************************************************************
571 * *
572 Type checking family instances
573 * *
574 ************************************************************************
575
576 Family instances are somewhat of a hybrid. They are processed together with
577 class instance heads, but can contain data constructors and hence they share a
578 lot of kinding and type checking code with ordinary algebraic data types (and
579 GADTs).
580 -}
581
582 tcFamInstDeclCombined :: Maybe ClsInstInfo
583 -> Located Name -> TcM TyCon
584 tcFamInstDeclCombined mb_clsinfo fam_tc_lname
585 = do { -- Type family instances require -XTypeFamilies
586 -- and can't (currently) be in an hs-boot file
587 ; traceTc "tcFamInstDecl" (ppr fam_tc_lname)
588 ; type_families <- xoptM LangExt.TypeFamilies
589 ; is_boot <- tcIsHsBootOrSig -- Are we compiling an hs-boot file?
590 ; checkTc type_families $ badFamInstDecl fam_tc_lname
591 ; checkTc (not is_boot) $ badBootFamInstDeclErr
592
593 -- Look up the family TyCon and check for validity including
594 -- check that toplevel type instances are not for associated types.
595 ; fam_tc <- tcLookupLocatedTyCon fam_tc_lname
596 ; when (isNothing mb_clsinfo && -- Not in a class decl
597 isTyConAssoc fam_tc) -- but an associated type
598 (addErr $ assocInClassErr fam_tc_lname)
599
600 ; return fam_tc }
601
602 tcTyFamInstDecl :: Maybe ClsInstInfo
603 -> LTyFamInstDecl GhcRn -> TcM FamInst
604 -- "type instance"
605 tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn }))
606 = setSrcSpan loc $
607 tcAddTyFamInstCtxt decl $
608 do { let fam_lname = feqn_tycon (hsib_body eqn)
609 ; fam_tc <- tcFamInstDeclCombined mb_clsinfo fam_lname
610
611 -- (0) Check it's an open type family
612 ; checkTc (isFamilyTyCon fam_tc) (notFamily fam_tc)
613 ; checkTc (isTypeFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc)
614 ; checkTc (isOpenTypeFamilyTyCon fam_tc) (notOpenFamily fam_tc)
615
616 -- (1) do the work of verifying the synonym group
617 ; co_ax_branch <- tcTyFamInstEqn fam_tc mb_clsinfo
618 (L (getLoc fam_lname) eqn)
619
620 -- (2) check for validity
621 ; checkValidCoAxBranch mb_clsinfo fam_tc co_ax_branch
622
623 -- (3) construct coercion axiom
624 ; rep_tc_name <- newFamInstAxiomName fam_lname [coAxBranchLHS co_ax_branch]
625 ; let axiom = mkUnbranchedCoAxiom rep_tc_name fam_tc co_ax_branch
626 ; newFamInst SynFamilyInst axiom }
627
628 tcDataFamInstDecl :: Maybe ClsInstInfo
629 -> LDataFamInstDecl GhcRn -> TcM (FamInst, Maybe DerivInfo)
630 -- "newtype instance" and "data instance"
631 tcDataFamInstDecl mb_clsinfo
632 (L loc decl@(DataFamInstDecl { dfid_eqn = HsIB { hsib_vars = tv_names
633 , hsib_body =
634 FamEqn { feqn_pats = pats
635 , feqn_tycon = fam_tc_name
636 , feqn_fixity = fixity
637 , feqn_rhs = HsDataDefn { dd_ND = new_or_data
638 , dd_cType = cType
639 , dd_ctxt = ctxt
640 , dd_cons = cons
641 , dd_kindSig = m_ksig
642 , dd_derivs = derivs } }}}))
643 = setSrcSpan loc $
644 tcAddDataFamInstCtxt decl $
645 do { fam_tc <- tcFamInstDeclCombined mb_clsinfo fam_tc_name
646
647 -- Check that the family declaration is for the right kind
648 ; checkTc (isFamilyTyCon fam_tc) (notFamily fam_tc)
649 ; checkTc (isDataFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc)
650
651 -- Kind check type patterns
652 ; let mb_kind_env = thdOf3 <$> mb_clsinfo
653 ; tcFamTyPats fam_tc mb_clsinfo tv_names pats
654 (kcDataDefn mb_kind_env decl) $
655 \tvs pats res_kind ->
656 do { stupid_theta <- solveEqualities $ tcHsContext ctxt
657
658 -- Zonk the patterns etc into the Type world
659 ; (ze, tvs') <- zonkTyBndrsX emptyZonkEnv tvs
660 ; pats' <- zonkTcTypeToTypes ze pats
661 ; res_kind' <- zonkTcTypeToType ze res_kind
662 ; stupid_theta' <- zonkTcTypeToTypes ze stupid_theta
663
664 ; gadt_syntax <- dataDeclChecks (tyConName fam_tc) new_or_data stupid_theta' cons
665
666 -- Construct representation tycon
667 ; rep_tc_name <- newFamInstTyConName fam_tc_name pats'
668 ; axiom_name <- newFamInstAxiomName fam_tc_name [pats']
669
670 ; let (eta_pats, etad_tvs) = eta_reduce pats'
671 eta_tvs = filterOut (`elem` etad_tvs) tvs'
672 -- NB: the "extra" tvs from tcDataKindSig would always be eta-reduced
673
674 full_tcbs = mkTyConBindersPreferAnon (eta_tvs ++ etad_tvs) res_kind'
675 -- Put the eta-removed tyvars at the end
676 -- Remember, tvs' is in arbitrary order (except kind vars are
677 -- first, so there is no reason to suppose that the etad_tvs
678 -- (obtained from the pats) are at the end (Trac #11148)
679
680 -- Deal with any kind signature.
681 -- See also Note [Arity of data families] in FamInstEnv
682 ; (extra_tcbs, final_res_kind) <- tcDataKindSig full_tcbs res_kind'
683 ; checkTc (isLiftedTypeKind final_res_kind) (badKindSig True res_kind')
684
685 ; let extra_pats = map (mkTyVarTy . binderVar) extra_tcbs
686 all_pats = pats' `chkAppend` extra_pats
687 orig_res_ty = mkTyConApp fam_tc all_pats
688
689 ; (rep_tc, axiom) <- fixM $ \ ~(rec_rep_tc, _) ->
690 do { let ty_binders = full_tcbs `chkAppend` extra_tcbs
691 ; data_cons <- tcConDecls rec_rep_tc
692 (ty_binders, orig_res_ty) cons
693 ; tc_rhs <- case new_or_data of
694 DataType -> return (mkDataTyConRhs data_cons)
695 NewType -> ASSERT( not (null data_cons) )
696 mkNewTyConRhs rep_tc_name rec_rep_tc (head data_cons)
697 -- freshen tyvars
698 ; let axiom = mkSingleCoAxiom Representational
699 axiom_name eta_tvs [] fam_tc eta_pats
700 (mkTyConApp rep_tc (mkTyVarTys eta_tvs))
701 parent = DataFamInstTyCon axiom fam_tc all_pats
702
703
704 -- NB: Use the full ty_binders from the pats. See bullet toward
705 -- the end of Note [Data type families] in TyCon
706 rep_tc = mkAlgTyCon rep_tc_name
707 ty_binders liftedTypeKind
708 (map (const Nominal) ty_binders)
709 (fmap unLoc cType) stupid_theta
710 tc_rhs parent
711 gadt_syntax
712 -- We always assume that indexed types are recursive. Why?
713 -- (1) Due to their open nature, we can never be sure that a
714 -- further instance might not introduce a new recursive
715 -- dependency. (2) They are always valid loop breakers as
716 -- they involve a coercion.
717 ; return (rep_tc, axiom) }
718
719 -- Remember to check validity; no recursion to worry about here
720 -- Check that left-hand sides are ok (mono-types, no type families,
721 -- consistent instantiations, etc)
722 ; checkValidFamPats mb_clsinfo fam_tc tvs' [] pats' extra_pats pp_hs_pats
723
724 -- Result kind must be '*' (otherwise, we have too few patterns)
725 ; checkTc (isLiftedTypeKind final_res_kind) $
726 tooFewParmsErr (tyConArity fam_tc)
727
728 ; checkValidTyCon rep_tc
729
730 ; let m_deriv_info = case derivs of
731 L _ [] -> Nothing
732 L _ preds ->
733 Just $ DerivInfo { di_rep_tc = rep_tc
734 , di_clauses = preds
735 , di_ctxt = tcMkDataFamInstCtxt decl }
736
737 ; fam_inst <- newFamInst (DataFamilyInst rep_tc) axiom
738 ; return (fam_inst, m_deriv_info) } }
739 where
740 eta_reduce :: [Type] -> ([Type], [TyVar])
741 -- See Note [Eta reduction for data families] in FamInstEnv
742 -- Splits the incoming patterns into two: the [TyVar]
743 -- are the patterns that can be eta-reduced away.
744 -- e.g. T [a] Int a d c ==> (T [a] Int a, [d,c])
745 --
746 -- NB: quadratic algorithm, but types are small here
747 eta_reduce pats
748 = go (reverse pats) []
749 go (pat:pats) etad_tvs
750 | Just tv <- getTyVar_maybe pat
751 , not (tv `elemVarSet` tyCoVarsOfTypes pats)
752 = go pats (tv : etad_tvs)
753 go pats etad_tvs = (reverse pats, etad_tvs)
754
755 pp_hs_pats = pprFamInstLHS fam_tc_name pats fixity (unLoc ctxt) m_ksig
756
757 {- *********************************************************************
758 * *
759 Type-checking instance declarations, pass 2
760 * *
761 ********************************************************************* -}
762
763 tcInstDecls2 :: [LTyClDecl GhcRn] -> [InstInfo GhcRn]
764 -> TcM (LHsBinds GhcTc)
765 -- (a) From each class declaration,
766 -- generate any default-method bindings
767 -- (b) From each instance decl
768 -- generate the dfun binding
769
770 tcInstDecls2 tycl_decls inst_decls
771 = do { -- (a) Default methods from class decls
772 let class_decls = filter (isClassDecl . unLoc) tycl_decls
773 ; dm_binds_s <- mapM tcClassDecl2 class_decls
774 ; let dm_binds = unionManyBags dm_binds_s
775
776 -- (b) instance declarations
777 ; let dm_ids = collectHsBindsBinders dm_binds
778 -- Add the default method Ids (again)
779 -- (they were arready added in TcTyDecls.tcAddImplicits)
780 -- See Note [Default methods in the type environment]
781 ; inst_binds_s <- tcExtendGlobalValEnv dm_ids $
782 mapM tcInstDecl2 inst_decls
783
784 -- Done
785 ; return (dm_binds `unionBags` unionManyBags inst_binds_s) }
786
787 {- Note [Default methods in the type environment]
788 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
789 The default method Ids are already in the type environment (see Note
790 [Default method Ids and Template Haskell] in TcTyDcls), BUT they
791 don't have their InlinePragmas yet. Usually that would not matter,
792 because the simplifier propagates information from binding site to
793 use. But, unusually, when compiling instance decls we *copy* the
794 INLINE pragma from the default method to the method for that
795 particular operation (see Note [INLINE and default methods] below).
796
797 So right here in tcInstDecls2 we must re-extend the type envt with
798 the default method Ids replete with their INLINE pragmas. Urk.
799 -}
800
801 tcInstDecl2 :: InstInfo GhcRn -> TcM (LHsBinds GhcTc)
802 -- Returns a binding for the dfun
803 tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
804 = recoverM (return emptyLHsBinds) $
805 setSrcSpan loc $
806 addErrCtxt (instDeclCtxt2 (idType dfun_id)) $
807 do { -- Instantiate the instance decl with skolem constants
808 ; (inst_tyvars, dfun_theta, inst_head) <- tcSkolDFunType dfun_id
809 ; dfun_ev_vars <- newEvVars dfun_theta
810 -- We instantiate the dfun_id with superSkolems.
811 -- See Note [Subtle interaction of recursion and overlap]
812 -- and Note [Binding when looking up instances]
813
814 ; let (clas, inst_tys) = tcSplitDFunHead inst_head
815 (class_tyvars, sc_theta, _, op_items) = classBigSig clas
816 sc_theta' = substTheta (zipTvSubst class_tyvars inst_tys) sc_theta
817
818 ; traceTc "tcInstDecl2" (vcat [ppr inst_tyvars, ppr inst_tys, ppr dfun_theta, ppr sc_theta'])
819
820 -- Deal with 'SPECIALISE instance' pragmas
821 -- See Note [SPECIALISE instance pragmas]
822 ; spec_inst_info@(spec_inst_prags,_) <- tcSpecInstPrags dfun_id ibinds
823
824 -- Typecheck superclasses and methods
825 -- See Note [Typechecking plan for instance declarations]
826 ; dfun_ev_binds_var <- newTcEvBinds
827 ; let dfun_ev_binds = TcEvBinds dfun_ev_binds_var
828 ; ((sc_meth_ids, sc_meth_binds, sc_meth_implics), tclvl)
829 <- pushTcLevelM $
830 do { (sc_ids, sc_binds, sc_implics)
831 <- tcSuperClasses dfun_id clas inst_tyvars dfun_ev_vars
832 inst_tys dfun_ev_binds
833 sc_theta'
834
835 -- Typecheck the methods
836 ; (meth_ids, meth_binds, meth_implics)
837 <- tcMethods dfun_id clas inst_tyvars dfun_ev_vars
838 inst_tys dfun_ev_binds spec_inst_info
839 op_items ibinds
840
841 ; return ( sc_ids ++ meth_ids
842 , sc_binds `unionBags` meth_binds
843 , sc_implics `unionBags` meth_implics ) }
844
845 ; env <- getLclEnv
846 ; emitImplication $ Implic { ic_tclvl = tclvl
847 , ic_skols = inst_tyvars
848 , ic_no_eqs = False
849 , ic_given = dfun_ev_vars
850 , ic_wanted = mkImplicWC sc_meth_implics
851 , ic_status = IC_Unsolved
852 , ic_binds = dfun_ev_binds_var
853 , ic_needed = emptyVarSet
854 , ic_env = env
855 , ic_info = InstSkol }
856
857 -- Create the result bindings
858 ; self_dict <- newDict clas inst_tys
859 ; let class_tc = classTyCon clas
860 [dict_constr] = tyConDataCons class_tc
861 dict_bind = mkVarBind self_dict (L loc con_app_args)
862
863 -- We don't produce a binding for the dict_constr; instead we
864 -- rely on the simplifier to unfold this saturated application
865 -- We do this rather than generate an HsCon directly, because
866 -- it means that the special cases (e.g. dictionary with only one
867 -- member) are dealt with by the common MkId.mkDataConWrapId
868 -- code rather than needing to be repeated here.
869 -- con_app_tys = MkD ty1 ty2
870 -- con_app_scs = MkD ty1 ty2 sc1 sc2
871 -- con_app_args = MkD ty1 ty2 sc1 sc2 op1 op2
872 con_app_tys = mkHsWrap (mkWpTyApps inst_tys)
873 (HsConLikeOut (RealDataCon dict_constr))
874 -- NB: We *can* have covars in inst_tys, in the case of
875 -- promoted GADT constructors.
876
877 con_app_args = foldl app_to_meth con_app_tys sc_meth_ids
878
879 app_to_meth :: HsExpr GhcTc -> Id -> HsExpr GhcTc
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 is_newtype = isNewTyCon class_tc
886 dfun_id_w_prags = addDFunPrags dfun_id sc_meth_ids
887 dfun_spec_prags
888 | is_newtype = SpecPrags []
889 | otherwise = SpecPrags spec_inst_prags
890 -- Newtype dfuns just inline unconditionally,
891 -- so don't attempt to specialise them
892
893 export = ABE { abe_wrap = idHsWrapper
894 , abe_poly = dfun_id_w_prags
895 , abe_mono = self_dict
896 , abe_prags = dfun_spec_prags }
897 -- NB: see Note [SPECIALISE instance pragmas]
898 main_bind = AbsBinds { abs_tvs = inst_tyvars
899 , abs_ev_vars = dfun_ev_vars
900 , abs_exports = [export]
901 , abs_ev_binds = []
902 , abs_binds = unitBag dict_bind
903 , abs_sig = True }
904
905 ; return (unitBag (L loc main_bind) `unionBags` sc_meth_binds)
906 }
907 where
908 dfun_id = instanceDFunId ispec
909 loc = getSrcSpan dfun_id
910
911 addDFunPrags :: DFunId -> [Id] -> DFunId
912 -- DFuns need a special Unfolding and InlinePrag
913 -- See Note [ClassOp/DFun selection]
914 -- and Note [Single-method classes]
915 -- It's easiest to create those unfoldings right here, where
916 -- have all the pieces in hand, even though we are messing with
917 -- Core at this point, which the typechecker doesn't usually do
918 -- However we take care to build the unfolding using the TyVars from
919 -- the DFunId rather than from the skolem pieces that the typechecker
920 -- is messing with.
921 addDFunPrags dfun_id sc_meth_ids
922 | is_newtype
923 = dfun_id `setIdUnfolding` mkInlineUnfoldingWithArity 0 con_app
924 `setInlinePragma` alwaysInlinePragma { inl_sat = Just 0 }
925 | otherwise
926 = dfun_id `setIdUnfolding` mkDFunUnfolding dfun_bndrs dict_con dict_args
927 `setInlinePragma` dfunInlinePragma
928 where
929 con_app = mkLams dfun_bndrs $
930 mkApps (Var (dataConWrapId dict_con)) dict_args
931 -- mkApps is OK because of the checkForLevPoly call in checkValidClass
932 -- See Note [Levity polymorphism checking] in DsMonad
933 dict_args = map Type inst_tys ++
934 [mkVarApps (Var id) dfun_bndrs | id <- sc_meth_ids]
935
936 (dfun_tvs, dfun_theta, clas, inst_tys) = tcSplitDFunTy (idType dfun_id)
937 ev_ids = mkTemplateLocalsNum 1 dfun_theta
938 dfun_bndrs = dfun_tvs ++ ev_ids
939 clas_tc = classTyCon clas
940 [dict_con] = tyConDataCons clas_tc
941 is_newtype = isNewTyCon clas_tc
942
943 wrapId :: HsWrapper -> IdP id -> HsExpr id
944 wrapId wrapper id = mkHsWrap wrapper (HsVar (noLoc id))
945
946 {- Note [Typechecking plan for instance declarations]
947 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
948 For instance declarations we generate the following bindings and implication
949 constraints. Example:
950
951 instance Ord a => Ord [a] where compare = <compare-rhs>
952
953 generates this:
954
955 Bindings:
956 -- Method bindings
957 $ccompare :: forall a. Ord a => a -> a -> Ordering
958 $ccompare = /\a \(d:Ord a). let <meth-ev-binds> in ...
959
960 -- Superclass bindings
961 $cp1Ord :: forall a. Ord a => Eq [a]
962 $cp1Ord = /\a \(d:Ord a). let <sc-ev-binds>
963 in dfEqList (dw :: Eq a)
964
965 Constraints:
966 forall a. Ord a =>
967 -- Method constraint
968 (forall. (empty) => <constraints from compare-rhs>)
969 -- Superclass constraint
970 /\ (forall. (empty) => dw :: Eq a)
971
972 Notice that
973
974 * Per-meth/sc implication. There is one inner implication per
975 superclass or method, with no skolem variables or givens. The only
976 reason for this one is to gather the evidence bindings privately
977 for this superclass or method. This implication is generated
978 by checkInstConstraints.
979
980 * Overall instance implication. There is an overall enclosing
981 implication for the whole instance declaration, with the expected
982 skolems and givens. We need this to get the correct "redundant
983 constraint" warnings, gathering all the uses from all the methods
984 and superclasses. See TcSimplify Note [Tracking redundant
985 constraints]
986
987 * The given constraints in the outer implication may generate
988 evidence, notably by superclass selection. Since the method and
989 superclass bindings are top-level, we want that evidence copied
990 into *every* method or superclass definition. (Some of it will
991 be usused in some, but dead-code elimination will drop it.)
992
993 We achieve this by putting the the evidence variable for the overall
994 instance implication into the AbsBinds for each method/superclass.
995 Hence the 'dfun_ev_binds' passed into tcMethods and tcSuperClasses.
996 (And that in turn is why the abs_ev_binds field of AbBinds is a
997 [TcEvBinds] rather than simply TcEvBinds.
998
999 This is a bit of a hack, but works very nicely in practice.
1000
1001 * Note that if a method has a locally-polymorphic binding, there will
1002 be yet another implication for that, generated by tcPolyCheck
1003 in tcMethodBody. E.g.
1004 class C a where
1005 foo :: forall b. Ord b => blah
1006
1007
1008 ************************************************************************
1009 * *
1010 Type-checking superclasses
1011 * *
1012 ************************************************************************
1013 -}
1014
1015 tcSuperClasses :: DFunId -> Class -> [TcTyVar] -> [EvVar] -> [TcType]
1016 -> TcEvBinds
1017 -> TcThetaType
1018 -> TcM ([EvVar], LHsBinds GhcTc, Bag Implication)
1019 -- Make a new top-level function binding for each superclass,
1020 -- something like
1021 -- $Ordp1 :: forall a. Ord a => Eq [a]
1022 -- $Ordp1 = /\a \(d:Ord a). dfunEqList a (sc_sel d)
1023 --
1024 -- See Note [Recursive superclasses] for why this is so hard!
1025 -- In effect, we build a special-purpose solver for the first step
1026 -- of solving each superclass constraint
1027 tcSuperClasses dfun_id cls tyvars dfun_evs inst_tys dfun_ev_binds sc_theta
1028 = do { (ids, binds, implics) <- mapAndUnzip3M tc_super (zip sc_theta [fIRST_TAG..])
1029 ; return (ids, listToBag binds, listToBag implics) }
1030 where
1031 loc = getSrcSpan dfun_id
1032 size = sizeTypes inst_tys
1033 tc_super (sc_pred, n)
1034 = do { (sc_implic, ev_binds_var, sc_ev_tm)
1035 <- checkInstConstraints $ emitWanted (ScOrigin size) sc_pred
1036
1037 ; sc_top_name <- newName (mkSuperDictAuxOcc n (getOccName cls))
1038 ; sc_ev_id <- newEvVar sc_pred
1039 ; addTcEvBind ev_binds_var $ mkWantedEvBind sc_ev_id sc_ev_tm
1040 ; let sc_top_ty = mkInvForAllTys tyvars (mkLamTypes dfun_evs sc_pred)
1041 sc_top_id = mkLocalId sc_top_name sc_top_ty
1042 export = ABE { abe_wrap = idHsWrapper
1043 , abe_poly = sc_top_id
1044 , abe_mono = sc_ev_id
1045 , abe_prags = noSpecPrags }
1046 local_ev_binds = TcEvBinds ev_binds_var
1047 bind = AbsBinds { abs_tvs = tyvars
1048 , abs_ev_vars = dfun_evs
1049 , abs_exports = [export]
1050 , abs_ev_binds = [dfun_ev_binds, local_ev_binds]
1051 , abs_binds = emptyBag
1052 , abs_sig = False }
1053 ; return (sc_top_id, L loc bind, sc_implic) }
1054
1055 -------------------
1056 checkInstConstraints :: TcM result
1057 -> TcM (Implication, EvBindsVar, result)
1058 -- See Note [Typechecking plan for instance declarations]
1059 checkInstConstraints thing_inside
1060 = do { (tclvl, wanted, result) <- pushLevelAndCaptureConstraints $
1061 thing_inside
1062
1063 ; ev_binds_var <- newTcEvBinds
1064 ; env <- getLclEnv
1065 ; let implic = Implic { ic_tclvl = tclvl
1066 , ic_skols = []
1067 , ic_no_eqs = False
1068 , ic_given = []
1069 , ic_wanted = wanted
1070 , ic_status = IC_Unsolved
1071 , ic_binds = ev_binds_var
1072 , ic_needed = emptyVarSet
1073 , ic_env = env
1074 , ic_info = InstSkol }
1075
1076 ; return (implic, ev_binds_var, result) }
1077
1078 {-
1079 Note [Recursive superclasses]
1080 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1081 See Trac #3731, #4809, #5751, #5913, #6117, #6161, which all
1082 describe somewhat more complicated situations, but ones
1083 encountered in practice.
1084
1085 See also tests tcrun020, tcrun021, tcrun033, and Trac #11427.
1086
1087 ----- THE PROBLEM --------
1088 The problem is that it is all too easy to create a class whose
1089 superclass is bottom when it should not be.
1090
1091 Consider the following (extreme) situation:
1092 class C a => D a where ...
1093 instance D [a] => D [a] where ... (dfunD)
1094 instance C [a] => C [a] where ... (dfunC)
1095 Although this looks wrong (assume D [a] to prove D [a]), it is only a
1096 more extreme case of what happens with recursive dictionaries, and it
1097 can, just about, make sense because the methods do some work before
1098 recursing.
1099
1100 To implement the dfunD we must generate code for the superclass C [a],
1101 which we had better not get by superclass selection from the supplied
1102 argument:
1103 dfunD :: forall a. D [a] -> D [a]
1104 dfunD = \d::D [a] -> MkD (scsel d) ..
1105
1106 Otherwise if we later encounter a situation where
1107 we have a [Wanted] dw::D [a] we might solve it thus:
1108 dw := dfunD dw
1109 Which is all fine except that now ** the superclass C is bottom **!
1110
1111 The instance we want is:
1112 dfunD :: forall a. D [a] -> D [a]
1113 dfunD = \d::D [a] -> MkD (dfunC (scsel d)) ...
1114
1115 ----- THE SOLUTION --------
1116 The basic solution is simple: be very careful about using superclass
1117 selection to generate a superclass witness in a dictionary function
1118 definition. More precisely:
1119
1120 Superclass Invariant: in every class dictionary,
1121 every superclass dictionary field
1122 is non-bottom
1123
1124 To achieve the Superclass Invariant, in a dfun definition we can
1125 generate a guaranteed-non-bottom superclass witness from:
1126 (sc1) one of the dictionary arguments itself (all non-bottom)
1127 (sc2) an immediate superclass of a smaller dictionary
1128 (sc3) a call of a dfun (always returns a dictionary constructor)
1129
1130 The tricky case is (sc2). We proceed by induction on the size of
1131 the (type of) the dictionary, defined by TcValidity.sizeTypes.
1132 Let's suppose we are building a dictionary of size 3, and
1133 suppose the Superclass Invariant holds of smaller dictionaries.
1134 Then if we have a smaller dictionary, its immediate superclasses
1135 will be non-bottom by induction.
1136
1137 What does "we have a smaller dictionary" mean? It might be
1138 one of the arguments of the instance, or one of its superclasses.
1139 Here is an example, taken from CmmExpr:
1140 class Ord r => UserOfRegs r a where ...
1141 (i1) instance UserOfRegs r a => UserOfRegs r (Maybe a) where
1142 (i2) instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r CmmExpr where
1143
1144 For (i1) we can get the (Ord r) superclass by selection from (UserOfRegs r a),
1145 since it is smaller than the thing we are building (UserOfRegs r (Maybe a).
1146
1147 But for (i2) that isn't the case, so we must add an explicit, and
1148 perhaps surprising, (Ord r) argument to the instance declaration.
1149
1150 Here's another example from Trac #6161:
1151
1152 class Super a => Duper a where ...
1153 class Duper (Fam a) => Foo a where ...
1154 (i3) instance Foo a => Duper (Fam a) where ...
1155 (i4) instance Foo Float where ...
1156
1157 It would be horribly wrong to define
1158 dfDuperFam :: Foo a -> Duper (Fam a) -- from (i3)
1159 dfDuperFam d = MkDuper (sc_sel1 (sc_sel2 d)) ...
1160
1161 dfFooFloat :: Foo Float -- from (i4)
1162 dfFooFloat = MkFoo (dfDuperFam dfFooFloat) ...
1163
1164 Now the Super superclass of Duper is definitely bottom!
1165
1166 This won't happen because when processing (i3) we can use the
1167 superclasses of (Foo a), which is smaller, namely Duper (Fam a). But
1168 that is *not* smaller than the target so we can't take *its*
1169 superclasses. As a result the program is rightly rejected, unless you
1170 add (Super (Fam a)) to the context of (i3).
1171
1172 Note [Solving superclass constraints]
1173 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1174 How do we ensure that every superclass witness is generated by
1175 one of (sc1) (sc2) or (sc3) in Note [Recursive superclasses].
1176 Answer:
1177
1178 * Superclass "wanted" constraints have CtOrigin of (ScOrigin size)
1179 where 'size' is the size of the instance declaration. e.g.
1180 class C a => D a where...
1181 instance blah => D [a] where ...
1182 The wanted superclass constraint for C [a] has origin
1183 ScOrigin size, where size = size( D [a] ).
1184
1185 * (sc1) When we rewrite such a wanted constraint, it retains its
1186 origin. But if we apply an instance declaration, we can set the
1187 origin to (ScOrigin infinity), thus lifting any restrictions by
1188 making prohibitedSuperClassSolve return False.
1189
1190 * (sc2) ScOrigin wanted constraints can't be solved from a
1191 superclass selection, except at a smaller type. This test is
1192 implemented by TcInteract.prohibitedSuperClassSolve
1193
1194 * The "given" constraints of an instance decl have CtOrigin
1195 GivenOrigin InstSkol.
1196
1197 * When we make a superclass selection from InstSkol we use
1198 a SkolemInfo of (InstSC size), where 'size' is the size of
1199 the constraint whose superclass we are taking. A similarly
1200 when taking the superclass of an InstSC. This is implemented
1201 in TcCanonical.newSCWorkFromFlavored
1202
1203 Note [Silent superclass arguments] (historical interest only)
1204 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1205 NB1: this note describes our *old* solution to the
1206 recursive-superclass problem. I'm keeping the Note
1207 for now, just as institutional memory.
1208 However, the code for silent superclass arguments
1209 was removed in late Dec 2014
1210
1211 NB2: the silent-superclass solution introduced new problems
1212 of its own, in the form of instance overlap. Tests
1213 SilentParametersOverlapping, T5051, and T7862 are examples
1214
1215 NB3: the silent-superclass solution also generated tons of
1216 extra dictionaries. For example, in monad-transformer
1217 code, when constructing a Monad dictionary you had to pass
1218 an Applicative dictionary; and to construct that you neede
1219 a Functor dictionary. Yet these extra dictionaries were
1220 often never used. Test T3064 compiled *far* faster after
1221 silent superclasses were eliminated.
1222
1223 Our solution to this problem "silent superclass arguments". We pass
1224 to each dfun some ``silent superclass arguments’’, which are the
1225 immediate superclasses of the dictionary we are trying to
1226 construct. In our example:
1227 dfun :: forall a. C [a] -> D [a] -> D [a]
1228 dfun = \(dc::C [a]) (dd::D [a]) -> DOrd dc ...
1229 Notice the extra (dc :: C [a]) argument compared to the previous version.
1230
1231 This gives us:
1232
1233 -----------------------------------------------------------
1234 DFun Superclass Invariant
1235 ~~~~~~~~~~~~~~~~~~~~~~~~
1236 In the body of a DFun, every superclass argument to the
1237 returned dictionary is
1238 either * one of the arguments of the DFun,
1239 or * constant, bound at top level
1240 -----------------------------------------------------------
1241
1242 This net effect is that it is safe to treat a dfun application as
1243 wrapping a dictionary constructor around its arguments (in particular,
1244 a dfun never picks superclasses from the arguments under the
1245 dictionary constructor). No superclass is hidden inside a dfun
1246 application.
1247
1248 The extra arguments required to satisfy the DFun Superclass Invariant
1249 always come first, and are called the "silent" arguments. You can
1250 find out how many silent arguments there are using Id.dfunNSilent;
1251 and then you can just drop that number of arguments to see the ones
1252 that were in the original instance declaration.
1253
1254 DFun types are built (only) by MkId.mkDictFunId, so that is where we
1255 decide what silent arguments are to be added.
1256 -}
1257
1258 {-
1259 ************************************************************************
1260 * *
1261 Type-checking an instance method
1262 * *
1263 ************************************************************************
1264
1265 tcMethod
1266 - Make the method bindings, as a [(NonRec, HsBinds)], one per method
1267 - Remembering to use fresh Name (the instance method Name) as the binder
1268 - Bring the instance method Ids into scope, for the benefit of tcInstSig
1269 - Use sig_fn mapping instance method Name -> instance tyvars
1270 - Ditto prag_fn
1271 - Use tcValBinds to do the checking
1272 -}
1273
1274 tcMethods :: DFunId -> Class
1275 -> [TcTyVar] -> [EvVar]
1276 -> [TcType]
1277 -> TcEvBinds
1278 -> ([Located TcSpecPrag], TcPragEnv)
1279 -> [ClassOpItem]
1280 -> InstBindings GhcRn
1281 -> TcM ([Id], LHsBinds GhcTc, Bag Implication)
1282 -- The returned inst_meth_ids all have types starting
1283 -- forall tvs. theta => ...
1284 tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys
1285 dfun_ev_binds (spec_inst_prags, prag_fn) op_items
1286 (InstBindings { ib_binds = binds
1287 , ib_tyvars = lexical_tvs
1288 , ib_pragmas = sigs
1289 , ib_extensions = exts
1290 , ib_derived = is_derived })
1291 = tcExtendTyVarEnv2 (lexical_tvs `zip` tyvars) $
1292 -- The lexical_tvs scope over the 'where' part
1293 do { traceTc "tcInstMeth" (ppr sigs $$ ppr binds)
1294 ; checkMinimalDefinition
1295 ; (ids, binds, mb_implics) <- set_exts exts $
1296 mapAndUnzip3M tc_item op_items
1297 ; return (ids, listToBag binds, listToBag (catMaybes mb_implics)) }
1298 where
1299 set_exts :: [LangExt.Extension] -> TcM a -> TcM a
1300 set_exts es thing = foldr setXOptM thing es
1301
1302 hs_sig_fn = mkHsSigFun sigs
1303 inst_loc = getSrcSpan dfun_id
1304
1305 ----------------------
1306 tc_item :: ClassOpItem -> TcM (Id, LHsBind GhcTc, Maybe Implication)
1307 tc_item (sel_id, dm_info)
1308 | Just (user_bind, bndr_loc, prags) <- findMethodBind (idName sel_id) binds prag_fn
1309 = tcMethodBody clas tyvars dfun_ev_vars inst_tys
1310 dfun_ev_binds is_derived hs_sig_fn
1311 spec_inst_prags prags
1312 sel_id user_bind bndr_loc
1313 | otherwise
1314 = do { traceTc "tc_def" (ppr sel_id)
1315 ; tc_default sel_id dm_info }
1316
1317 ----------------------
1318 tc_default :: Id -> DefMethInfo
1319 -> TcM (TcId, LHsBind GhcTc, Maybe Implication)
1320
1321 tc_default sel_id (Just (dm_name, _))
1322 = do { (meth_bind, inline_prags) <- mkDefMethBind clas inst_tys sel_id dm_name
1323 ; tcMethodBody clas tyvars dfun_ev_vars inst_tys
1324 dfun_ev_binds is_derived hs_sig_fn
1325 spec_inst_prags inline_prags
1326 sel_id meth_bind inst_loc }
1327
1328 tc_default sel_id Nothing -- No default method at all
1329 = do { traceTc "tc_def: warn" (ppr sel_id)
1330 ; (meth_id, _) <- mkMethIds clas tyvars dfun_ev_vars
1331 inst_tys sel_id
1332 ; dflags <- getDynFlags
1333 ; let meth_bind = mkVarBind meth_id $
1334 mkLHsWrap lam_wrapper (error_rhs dflags)
1335 ; return (meth_id, meth_bind, Nothing) }
1336 where
1337 error_rhs dflags = L inst_loc $ HsApp error_fun (error_msg dflags)
1338 error_fun = L inst_loc $
1339 wrapId (mkWpTyApps
1340 [ getRuntimeRep meth_tau, meth_tau])
1341 nO_METHOD_BINDING_ERROR_ID
1342 error_msg dflags = L inst_loc (HsLit (HsStringPrim noSourceText
1343 (unsafeMkByteString (error_string dflags))))
1344 meth_tau = funResultTy (piResultTys (idType sel_id) inst_tys)
1345 error_string dflags = showSDoc dflags
1346 (hcat [ppr inst_loc, vbar, ppr sel_id ])
1347 lam_wrapper = mkWpTyLams tyvars <.> mkWpLams dfun_ev_vars
1348
1349 ----------------------
1350 -- Check if one of the minimal complete definitions is satisfied
1351 checkMinimalDefinition
1352 = whenIsJust (isUnsatisfied methodExists (classMinimalDef clas)) $
1353 warnUnsatisfiedMinimalDefinition
1354
1355 methodExists meth = isJust (findMethodBind meth binds prag_fn)
1356
1357 ------------------------
1358 tcMethodBody :: Class -> [TcTyVar] -> [EvVar] -> [TcType]
1359 -> TcEvBinds -> Bool
1360 -> HsSigFun
1361 -> [LTcSpecPrag] -> [LSig GhcRn]
1362 -> Id -> LHsBind GhcRn -> SrcSpan
1363 -> TcM (TcId, LHsBind GhcTc, Maybe Implication)
1364 tcMethodBody clas tyvars dfun_ev_vars inst_tys
1365 dfun_ev_binds is_derived
1366 sig_fn spec_inst_prags prags
1367 sel_id (L bind_loc meth_bind) bndr_loc
1368 = add_meth_ctxt $
1369 do { traceTc "tcMethodBody" (ppr sel_id <+> ppr (idType sel_id) $$ ppr bndr_loc)
1370 ; (global_meth_id, local_meth_id) <- setSrcSpan bndr_loc $
1371 mkMethIds clas tyvars dfun_ev_vars
1372 inst_tys sel_id
1373
1374 ; let lm_bind = meth_bind { fun_id = L bndr_loc (idName local_meth_id) }
1375 -- Substitute the local_meth_name for the binder
1376 -- NB: the binding is always a FunBind
1377
1378 -- taking instance signature into account might change the type of
1379 -- the local_meth_id
1380 ; (meth_implic, ev_binds_var, tc_bind)
1381 <- checkInstConstraints $
1382 tcMethodBodyHelp sig_fn sel_id local_meth_id (L bind_loc lm_bind)
1383
1384 ; global_meth_id <- addInlinePrags global_meth_id prags
1385 ; spec_prags <- tcSpecPrags global_meth_id prags
1386
1387 ; let specs = mk_meth_spec_prags global_meth_id spec_inst_prags spec_prags
1388 export = ABE { abe_poly = global_meth_id
1389 , abe_mono = local_meth_id
1390 , abe_wrap = idHsWrapper
1391 , abe_prags = specs }
1392
1393 local_ev_binds = TcEvBinds ev_binds_var
1394 full_bind = AbsBinds { abs_tvs = tyvars
1395 , abs_ev_vars = dfun_ev_vars
1396 , abs_exports = [export]
1397 , abs_ev_binds = [dfun_ev_binds, local_ev_binds]
1398 , abs_binds = tc_bind
1399 , abs_sig = True }
1400
1401 ; return (global_meth_id, L bind_loc full_bind, Just meth_implic) }
1402 where
1403 -- For instance decls that come from deriving clauses
1404 -- we want to print out the full source code if there's an error
1405 -- because otherwise the user won't see the code at all
1406 add_meth_ctxt thing
1407 | is_derived = addLandmarkErrCtxt (derivBindCtxt sel_id clas inst_tys) thing
1408 | otherwise = thing
1409
1410 tcMethodBodyHelp :: HsSigFun -> Id -> TcId
1411 -> LHsBind GhcRn -> TcM (LHsBinds GhcTcId)
1412 tcMethodBodyHelp hs_sig_fn sel_id local_meth_id meth_bind
1413 | Just hs_sig_ty <- hs_sig_fn sel_name
1414 -- There is a signature in the instance
1415 -- See Note [Instance method signatures]
1416 = do { let ctxt = FunSigCtxt sel_name True
1417 ; (sig_ty, hs_wrap)
1418 <- setSrcSpan (getLoc (hsSigType hs_sig_ty)) $
1419 do { inst_sigs <- xoptM LangExt.InstanceSigs
1420 ; checkTc inst_sigs (misplacedInstSig sel_name hs_sig_ty)
1421 ; sig_ty <- tcHsSigType (FunSigCtxt sel_name False) hs_sig_ty
1422 ; let local_meth_ty = idType local_meth_id
1423 ; hs_wrap <- addErrCtxtM (methSigCtxt sel_name sig_ty local_meth_ty) $
1424 tcSubType_NC ctxt sig_ty local_meth_ty
1425 ; return (sig_ty, hs_wrap) }
1426
1427 ; inner_meth_name <- newName (nameOccName sel_name)
1428 ; let inner_meth_id = mkLocalId inner_meth_name sig_ty
1429 inner_meth_sig = CompleteSig { sig_bndr = inner_meth_id
1430 , sig_ctxt = ctxt
1431 , sig_loc = getLoc (hsSigType hs_sig_ty) }
1432
1433
1434 ; (tc_bind, [inner_id]) <- tcPolyCheck no_prag_fn inner_meth_sig meth_bind
1435
1436 ; let export = ABE { abe_poly = local_meth_id
1437 , abe_mono = inner_id
1438 , abe_wrap = hs_wrap
1439 , abe_prags = noSpecPrags }
1440
1441 ; return (unitBag $ L (getLoc meth_bind) $
1442 AbsBinds { abs_tvs = [], abs_ev_vars = []
1443 , abs_exports = [export]
1444 , abs_binds = tc_bind, abs_ev_binds = []
1445 , abs_sig = True }) }
1446
1447 | otherwise -- No instance signature
1448 = do { let ctxt = FunSigCtxt sel_name False
1449 -- False <=> don't report redundant constraints
1450 -- The signature is not under the users control!
1451 tc_sig = completeSigFromId ctxt local_meth_id
1452 -- Absent a type sig, there are no new scoped type variables here
1453 -- Only the ones from the instance decl itself, which are already
1454 -- in scope. Example:
1455 -- class C a where { op :: forall b. Eq b => ... }
1456 -- instance C [c] where { op = <rhs> }
1457 -- In <rhs>, 'c' is scope but 'b' is not!
1458
1459 ; (tc_bind, _) <- tcPolyCheck no_prag_fn tc_sig meth_bind
1460 ; return tc_bind }
1461
1462 where
1463 sel_name = idName sel_id
1464 no_prag_fn = emptyPragEnv -- No pragmas for local_meth_id;
1465 -- they are all for meth_id
1466
1467
1468 ------------------------
1469 mkMethIds :: Class -> [TcTyVar] -> [EvVar]
1470 -> [TcType] -> Id -> TcM (TcId, TcId)
1471 -- returns (poly_id, local_id), but ignoring any instance signature
1472 -- See Note [Instance method signatures]
1473 mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id
1474 = do { poly_meth_name <- newName (mkClassOpAuxOcc sel_occ)
1475 ; local_meth_name <- newName sel_occ
1476 -- Base the local_meth_name on the selector name, because
1477 -- type errors from tcMethodBody come from here
1478 ; let poly_meth_id = mkLocalId poly_meth_name poly_meth_ty
1479 local_meth_id = mkLocalId local_meth_name local_meth_ty
1480
1481 ; return (poly_meth_id, local_meth_id) }
1482 where
1483 sel_name = idName sel_id
1484 sel_occ = nameOccName sel_name
1485 local_meth_ty = instantiateMethod clas sel_id inst_tys
1486 poly_meth_ty = mkSpecSigmaTy tyvars theta local_meth_ty
1487 theta = map idType dfun_ev_vars
1488
1489 methSigCtxt :: Name -> TcType -> TcType -> TidyEnv -> TcM (TidyEnv, MsgDoc)
1490 methSigCtxt sel_name sig_ty meth_ty env0
1491 = do { (env1, sig_ty) <- zonkTidyTcType env0 sig_ty
1492 ; (env2, meth_ty) <- zonkTidyTcType env1 meth_ty
1493 ; let msg = hang (text "When checking that instance signature for" <+> quotes (ppr sel_name))
1494 2 (vcat [ text "is more general than its signature in the class"
1495 , text "Instance sig:" <+> ppr sig_ty
1496 , text " Class sig:" <+> ppr meth_ty ])
1497 ; return (env2, msg) }
1498
1499 misplacedInstSig :: Name -> LHsSigType GhcRn -> SDoc
1500 misplacedInstSig name hs_ty
1501 = vcat [ hang (text "Illegal type signature in instance declaration:")
1502 2 (hang (pprPrefixName name)
1503 2 (dcolon <+> ppr hs_ty))
1504 , text "(Use InstanceSigs to allow this)" ]
1505
1506 {- Note [Instance method signatures]
1507 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1508 With -XInstanceSigs we allow the user to supply a signature for the
1509 method in an instance declaration. Here is an artificial example:
1510
1511 data T a = MkT a
1512 instance Ord a => Ord (T a) where
1513 (>) :: forall b. b -> b -> Bool
1514 (>) = error "You can't compare Ts"
1515
1516 The instance signature can be *more* polymorphic than the instantiated
1517 class method (in this case: Age -> Age -> Bool), but it cannot be less
1518 polymorphic. Moreover, if a signature is given, the implementation
1519 code should match the signature, and type variables bound in the
1520 singature should scope over the method body.
1521
1522 We achieve this by building a TcSigInfo for the method, whether or not
1523 there is an instance method signature, and using that to typecheck
1524 the declaration (in tcMethodBody). That means, conveniently,
1525 that the type variables bound in the signature will scope over the body.
1526
1527 What about the check that the instance method signature is more
1528 polymorphic than the instantiated class method type? We just do a
1529 tcSubType call in tcMethodBodyHelp, and generate a nested AbsBind, like
1530 this (for the example above
1531
1532 AbsBind { abs_tvs = [a], abs_ev_vars = [d:Ord a]
1533 , abs_exports
1534 = ABExport { (>) :: forall a. Ord a => T a -> T a -> Bool
1535 , gr_lcl :: T a -> T a -> Bool }
1536 , abs_binds
1537 = AbsBind { abs_tvs = [], abs_ev_vars = []
1538 , abs_exports = ABExport { gr_lcl :: T a -> T a -> Bool
1539 , gr_inner :: forall b. b -> b -> Bool }
1540 , abs_binds = AbsBind { abs_tvs = [b], abs_ev_vars = []
1541 , ..etc.. }
1542 } }
1543
1544 Wow! Three nested AbsBinds!
1545 * The outer one abstracts over the tyvars and dicts for the instance
1546 * The middle one is only present if there is an instance signature,
1547 and does the impedance matching for that signature
1548 * The inner one is for the method binding itself against either the
1549 signature from the class, or the the instance signature.
1550 -}
1551
1552 ----------------------
1553 mk_meth_spec_prags :: Id -> [LTcSpecPrag] -> [LTcSpecPrag] -> TcSpecPrags
1554 -- Adapt the 'SPECIALISE instance' pragmas to work for this method Id
1555 -- There are two sources:
1556 -- * spec_prags_for_me: {-# SPECIALISE op :: <blah> #-}
1557 -- * spec_prags_from_inst: derived from {-# SPECIALISE instance :: <blah> #-}
1558 -- These ones have the dfun inside, but [perhaps surprisingly]
1559 -- the correct wrapper.
1560 -- See Note [Handling SPECIALISE pragmas] in TcBinds
1561 mk_meth_spec_prags meth_id spec_inst_prags spec_prags_for_me
1562 = SpecPrags (spec_prags_for_me ++ spec_prags_from_inst)
1563 where
1564 spec_prags_from_inst
1565 | isInlinePragma (idInlinePragma meth_id)
1566 = [] -- Do not inherit SPECIALISE from the instance if the
1567 -- method is marked INLINE, because then it'll be inlined
1568 -- and the specialisation would do nothing. (Indeed it'll provoke
1569 -- a warning from the desugarer
1570 | otherwise
1571 = [ L inst_loc (SpecPrag meth_id wrap inl)
1572 | L inst_loc (SpecPrag _ wrap inl) <- spec_inst_prags]
1573
1574
1575 mkDefMethBind :: Class -> [Type] -> Id -> Name
1576 -> TcM (LHsBind GhcRn, [LSig GhcRn])
1577 -- The is a default method (vanailla or generic) defined in the class
1578 -- So make a binding op = $dmop @t1 @t2
1579 -- where $dmop is the name of the default method in the class,
1580 -- and t1,t2 are the instance types.
1581 -- See Note [Default methods in instances] for why we use
1582 -- visible type application here
1583 mkDefMethBind clas inst_tys sel_id dm_name
1584 = do { dflags <- getDynFlags
1585 ; dm_id <- tcLookupId dm_name
1586 ; let inline_prag = idInlinePragma dm_id
1587 inline_prags | isAnyInlinePragma inline_prag
1588 = [noLoc (InlineSig fn inline_prag)]
1589 | otherwise
1590 = []
1591 -- Copy the inline pragma (if any) from the default method
1592 -- to this version. Note [INLINE and default methods]
1593
1594 fn = noLoc (idName sel_id)
1595 visible_inst_tys = [ ty | (tcb, ty) <- tyConBinders (classTyCon clas) `zip` inst_tys
1596 , tyConBinderArgFlag tcb /= Inferred ]
1597 rhs = foldl mk_vta (nlHsVar dm_name) visible_inst_tys
1598 bind = noLoc $ mkTopFunBind Generated fn $
1599 [mkSimpleMatch (mkPrefixFunRhs fn) [] rhs]
1600
1601 ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body"
1602 (vcat [ppr clas <+> ppr inst_tys,
1603 nest 2 (ppr sel_id <+> equals <+> ppr rhs)]))
1604
1605 ; return (bind, inline_prags) }
1606 where
1607 mk_vta :: LHsExpr GhcRn -> Type -> LHsExpr GhcRn
1608 mk_vta fun ty = noLoc (HsAppType fun (mkEmptyWildCardBndrs
1609 $ nlHsParTy $ noLoc $ HsCoreTy ty))
1610 -- NB: use visible type application
1611 -- See Note [Default methods in instances]
1612
1613 ----------------------
1614 derivBindCtxt :: Id -> Class -> [Type ] -> SDoc
1615 derivBindCtxt sel_id clas tys
1616 = vcat [ text "When typechecking the code for" <+> quotes (ppr sel_id)
1617 , nest 2 (text "in a derived instance for"
1618 <+> quotes (pprClassPred clas tys) <> colon)
1619 , nest 2 $ text "To see the code I am typechecking, use -ddump-deriv" ]
1620
1621 warnUnsatisfiedMinimalDefinition :: ClassMinimalDef -> TcM ()
1622 warnUnsatisfiedMinimalDefinition mindef
1623 = do { warn <- woptM Opt_WarnMissingMethods
1624 ; warnTc (Reason Opt_WarnMissingMethods) warn message
1625 }
1626 where
1627 message = vcat [text "No explicit implementation for"
1628 ,nest 2 $ pprBooleanFormulaNice mindef
1629 ]
1630
1631 {-
1632 Note [Export helper functions]
1633 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1634 We arrange to export the "helper functions" of an instance declaration,
1635 so that they are not subject to preInlineUnconditionally, even if their
1636 RHS is trivial. Reason: they are mentioned in the DFunUnfolding of
1637 the dict fun as Ids, not as CoreExprs, so we can't substitute a
1638 non-variable for them.
1639
1640 We could change this by making DFunUnfoldings have CoreExprs, but it
1641 seems a bit simpler this way.
1642
1643 Note [Default methods in instances]
1644 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1645 Consider this
1646
1647 class Baz v x where
1648 foo :: x -> x
1649 foo y = <blah>
1650
1651 instance Baz Int Int
1652
1653 From the class decl we get
1654
1655 $dmfoo :: forall v x. Baz v x => x -> x
1656 $dmfoo y = <blah>
1657
1658 Notice that the type is ambiguous. So we use Visible Type Application
1659 to disambiguate:
1660
1661 $dBazIntInt = MkBaz fooIntInt
1662 fooIntInt = $dmfoo @Int @Int
1663
1664 Lacking VTA we'd get ambiguity errors involving the default method. This applies
1665 equally to vanilla default methods (Trac #1061) and generic default methods
1666 (Trac #12220).
1667
1668 Historical note: before we had VTA we had to generate
1669 post-type-checked code, which took a lot more code, and didn't work for
1670 generic default methods.
1671
1672 Note [INLINE and default methods]
1673 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1674 Default methods need special case. They are supposed to behave rather like
1675 macros. For example
1676
1677 class Foo a where
1678 op1, op2 :: Bool -> a -> a
1679
1680 {-# INLINE op1 #-}
1681 op1 b x = op2 (not b) x
1682
1683 instance Foo Int where
1684 -- op1 via default method
1685 op2 b x = <blah>
1686
1687 The instance declaration should behave
1688
1689 just as if 'op1' had been defined with the
1690 code, and INLINE pragma, from its original
1691 definition.
1692
1693 That is, just as if you'd written
1694
1695 instance Foo Int where
1696 op2 b x = <blah>
1697
1698 {-# INLINE op1 #-}
1699 op1 b x = op2 (not b) x
1700
1701 So for the above example we generate:
1702
1703 {-# INLINE $dmop1 #-}
1704 -- $dmop1 has an InlineCompulsory unfolding
1705 $dmop1 d b x = op2 d (not b) x
1706
1707 $fFooInt = MkD $cop1 $cop2
1708
1709 {-# INLINE $cop1 #-}
1710 $cop1 = $dmop1 $fFooInt
1711
1712 $cop2 = <blah>
1713
1714 Note carefully:
1715
1716 * We *copy* any INLINE pragma from the default method $dmop1 to the
1717 instance $cop1. Otherwise we'll just inline the former in the
1718 latter and stop, which isn't what the user expected
1719
1720 * Regardless of its pragma, we give the default method an
1721 unfolding with an InlineCompulsory source. That means
1722 that it'll be inlined at every use site, notably in
1723 each instance declaration, such as $cop1. This inlining
1724 must happen even though
1725 a) $dmop1 is not saturated in $cop1
1726 b) $cop1 itself has an INLINE pragma
1727
1728 It's vital that $dmop1 *is* inlined in this way, to allow the mutual
1729 recursion between $fooInt and $cop1 to be broken
1730
1731 * To communicate the need for an InlineCompulsory to the desugarer
1732 (which makes the Unfoldings), we use the IsDefaultMethod constructor
1733 in TcSpecPrags.
1734
1735
1736 ************************************************************************
1737 * *
1738 Specialise instance pragmas
1739 * *
1740 ************************************************************************
1741
1742 Note [SPECIALISE instance pragmas]
1743 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1744 Consider
1745
1746 instance (Ix a, Ix b) => Ix (a,b) where
1747 {-# SPECIALISE instance Ix (Int,Int) #-}
1748 range (x,y) = ...
1749
1750 We make a specialised version of the dictionary function, AND
1751 specialised versions of each *method*. Thus we should generate
1752 something like this:
1753
1754 $dfIxPair :: (Ix a, Ix b) => Ix (a,b)
1755 {-# DFUN [$crangePair, ...] #-}
1756 {-# SPECIALISE $dfIxPair :: Ix (Int,Int) #-}
1757 $dfIxPair da db = Ix ($crangePair da db) (...other methods...)
1758
1759 $crange :: (Ix a, Ix b) -> ((a,b),(a,b)) -> [(a,b)]
1760 {-# SPECIALISE $crange :: ((Int,Int),(Int,Int)) -> [(Int,Int)] #-}
1761 $crange da db = <blah>
1762
1763 The SPECIALISE pragmas are acted upon by the desugarer, which generate
1764
1765 dii :: Ix Int
1766 dii = ...
1767
1768 $s$dfIxPair :: Ix ((Int,Int),(Int,Int))
1769 {-# DFUN [$crangePair di di, ...] #-}
1770 $s$dfIxPair = Ix ($crangePair di di) (...)
1771
1772 {-# RULE forall (d1,d2:Ix Int). $dfIxPair Int Int d1 d2 = $s$dfIxPair #-}
1773
1774 $s$crangePair :: ((Int,Int),(Int,Int)) -> [(Int,Int)]
1775 $c$crangePair = ...specialised RHS of $crangePair...
1776
1777 {-# RULE forall (d1,d2:Ix Int). $crangePair Int Int d1 d2 = $s$crangePair #-}
1778
1779 Note that
1780
1781 * The specialised dictionary $s$dfIxPair is very much needed, in case we
1782 call a function that takes a dictionary, but in a context where the
1783 specialised dictionary can be used. See Trac #7797.
1784
1785 * The ClassOp rule for 'range' works equally well on $s$dfIxPair, because
1786 it still has a DFunUnfolding. See Note [ClassOp/DFun selection]
1787
1788 * A call (range ($dfIxPair Int Int d1 d2)) might simplify two ways:
1789 --> {ClassOp rule for range} $crangePair Int Int d1 d2
1790 --> {SPEC rule for $crangePair} $s$crangePair
1791 or thus:
1792 --> {SPEC rule for $dfIxPair} range $s$dfIxPair
1793 --> {ClassOpRule for range} $s$crangePair
1794 It doesn't matter which way.
1795
1796 * We want to specialise the RHS of both $dfIxPair and $crangePair,
1797 but the SAME HsWrapper will do for both! We can call tcSpecPrag
1798 just once, and pass the result (in spec_inst_info) to tcMethods.
1799 -}
1800
1801 tcSpecInstPrags :: DFunId -> InstBindings GhcRn
1802 -> TcM ([Located TcSpecPrag], TcPragEnv)
1803 tcSpecInstPrags dfun_id (InstBindings { ib_binds = binds, ib_pragmas = uprags })
1804 = do { spec_inst_prags <- mapM (wrapLocM (tcSpecInst dfun_id)) $
1805 filter isSpecInstLSig uprags
1806 -- The filter removes the pragmas for methods
1807 ; return (spec_inst_prags, mkPragEnv uprags binds) }
1808
1809 ------------------------------
1810 tcSpecInst :: Id -> Sig GhcRn -> TcM TcSpecPrag
1811 tcSpecInst dfun_id prag@(SpecInstSig _ hs_ty)
1812 = addErrCtxt (spec_ctxt prag) $
1813 do { (tyvars, theta, clas, tys) <- tcHsClsInstType SpecInstCtxt hs_ty
1814 ; let spec_dfun_ty = mkDictFunTy tyvars theta clas tys
1815 ; co_fn <- tcSpecWrapper SpecInstCtxt (idType dfun_id) spec_dfun_ty
1816 ; return (SpecPrag dfun_id co_fn defaultInlinePragma) }
1817 where
1818 spec_ctxt prag = hang (text "In the SPECIALISE pragma") 2 (ppr prag)
1819
1820 tcSpecInst _ _ = panic "tcSpecInst"
1821
1822 {-
1823 ************************************************************************
1824 * *
1825 \subsection{Error messages}
1826 * *
1827 ************************************************************************
1828 -}
1829
1830 instDeclCtxt1 :: LHsSigType GhcRn -> SDoc
1831 instDeclCtxt1 hs_inst_ty
1832 = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty))
1833
1834 instDeclCtxt2 :: Type -> SDoc
1835 instDeclCtxt2 dfun_ty
1836 = inst_decl_ctxt (ppr (mkClassPred cls tys))
1837 where
1838 (_,_,cls,tys) = tcSplitDFunTy dfun_ty
1839
1840 inst_decl_ctxt :: SDoc -> SDoc
1841 inst_decl_ctxt doc = hang (text "In the instance declaration for")
1842 2 (quotes doc)
1843
1844 badBootFamInstDeclErr :: SDoc
1845 badBootFamInstDeclErr
1846 = text "Illegal family instance in hs-boot file"
1847
1848 notFamily :: TyCon -> SDoc
1849 notFamily tycon
1850 = vcat [ text "Illegal family instance for" <+> quotes (ppr tycon)
1851 , nest 2 $ parens (ppr tycon <+> text "is not an indexed type family")]
1852
1853 tooFewParmsErr :: Arity -> SDoc
1854 tooFewParmsErr arity
1855 = text "Family instance has too few parameters; expected" <+>
1856 ppr arity
1857
1858 assocInClassErr :: Located Name -> SDoc
1859 assocInClassErr name
1860 = text "Associated type" <+> quotes (ppr name) <+>
1861 text "must be inside a class instance"
1862
1863 badFamInstDecl :: Located Name -> SDoc
1864 badFamInstDecl tc_name
1865 = vcat [ text "Illegal family instance for" <+>
1866 quotes (ppr tc_name)
1867 , nest 2 (parens $ text "Use TypeFamilies to allow indexed type families") ]
1868
1869 notOpenFamily :: TyCon -> SDoc
1870 notOpenFamily tc
1871 = text "Illegal instance for closed family" <+> quotes (ppr tc)