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