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