2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
6 TcInstDecls: Typechecking instance declarations
9 module TcInstDcls ( tcInstDecls1, tcInstDecls2 ) where
15 import TcPat( addInlinePrags )
16 import TcSimplify( simplifyTop )
24 import MkCore ( nO_METHOD_BINDING_ERROR_ID )
27 import RnSource ( addTcgDUs )
37 import CoreUtils ( mkPiTypes )
38 import CoreUnfold ( mkDFunUnfolding )
39 import CoreSyn ( Expr(Var), DFunArg(..), CoreExpr )
52 import Maybes ( orElse )
57 #include "HsVersions.h"
60 Typechecking instance declarations is done in two passes. The first
61 pass, made by @tcInstDecls1@, collects information to be used in the
64 This pre-processed info includes the as-yet-unprocessed bindings
65 inside the instance declaration. These are type-checked in the second
66 pass, when the class-instance envs and GVE contain all the info from
67 all the instance and value decls. Indeed that's the reason we need
68 two passes over the instance decls.
71 Note [How instance declarations are translated]
72 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
73 Here is how we translation instance declarations into Core
77 op1, op2 :: Ix b => a -> b -> b
81 {-# INLINE [2] op1 #-}
85 op1,op2 :: forall a. C a => forall b. Ix b => a -> b -> b
89 -- Default methods get the 'self' dictionary as argument
90 -- so they can call other methods at the same type
91 -- Default methods get the same type as their method selector
92 $dmop2 :: forall a. C a => forall b. Ix b => a -> b -> b
93 $dmop2 = /\a. \(d:C a). /\b. \(d2: Ix b). <dm-rhs>
94 -- NB: type variables 'a' and 'b' are *both* in scope in <dm-rhs>
95 -- Note [Tricky type variable scoping]
97 -- A top-level definition for each instance method
98 -- Here op1_i, op2_i are the "instance method Ids"
99 -- The INLINE pragma comes from the user pragma
100 {-# INLINE [2] op1_i #-} -- From the instance decl bindings
101 op1_i, op2_i :: forall a. C a => forall b. Ix b => [a] -> b -> b
102 op1_i = /\a. \(d:C a).
105 -- Note [Subtle interaction of recursion and overlap]
107 local_op1 :: forall b. Ix b => [a] -> b -> b
109 -- Source code; run the type checker on this
110 -- NB: Type variable 'a' (but not 'b') is in scope in <rhs>
111 -- Note [Tricky type variable scoping]
115 op2_i = /\a \d:C a. $dmop2 [a] (df_i a d)
117 -- The dictionary function itself
118 {-# NOINLINE CONLIKE df_i #-} -- Never inline dictionary functions
119 df_i :: forall a. C a -> C [a]
120 df_i = /\a. \d:C a. MkC (op1_i a d) (op2_i a d)
121 -- But see Note [Default methods in instances]
122 -- We can't apply the type checker to the default-method call
124 -- Use a RULE to short-circuit applications of the class ops
125 {-# RULE "op1@C[a]" forall a, d:C a.
126 op1 [a] (df_i d) = op1_i a d #-}
128 Note [Instances and loop breakers]
129 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
130 * Note that df_i may be mutually recursive with both op1_i and op2_i.
131 It's crucial that df_i is not chosen as the loop breaker, even
132 though op1_i has a (user-specified) INLINE pragma.
134 * Instead the idea is to inline df_i into op1_i, which may then select
135 methods from the MkC record, and thereby break the recursion with
136 df_i, leaving a *self*-recurisve op1_i. (If op1_i doesn't call op at
137 the same type, it won't mention df_i, so there won't be recursion in
140 * If op1_i is marked INLINE by the user there's a danger that we won't
141 inline df_i in it, and that in turn means that (since it'll be a
142 loop-breaker because df_i isn't), op1_i will ironically never be
143 inlined. But this is OK: the recursion breaking happens by way of
144 a RULE (the magic ClassOp rule above), and RULES work inside InlineRule
145 unfoldings. See Note [RULEs enabled in SimplGently] in SimplUtils
147 Note [ClassOp/DFun selection]
148 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
149 One thing we see a lot is stuff like
151 where 'op2' is a ClassOp and 'df' is DFun. Now, we could inline *both*
152 'op2' and 'df' to get
153 case (MkD ($cop1 d1 d2) ($cop2 d1 d2) ... of
154 MkD _ op2 _ _ _ -> op2
155 And that will reduce to ($cop2 d1 d2) which is what we wanted.
157 But it's tricky to make this work in practice, because it requires us to
158 inline both 'op2' and 'df'. But neither is keen to inline without having
159 seen the other's result; and it's very easy to get code bloat (from the
160 big intermediate) if you inline a bit too much.
162 Instead we use a cunning trick.
163 * We arrange that 'df' and 'op2' NEVER inline.
165 * We arrange that 'df' is ALWAYS defined in the sylised form
166 df d1 d2 = MkD ($cop1 d1 d2) ($cop2 d1 d2) ...
168 * We give 'df' a magical unfolding (DFunUnfolding [$cop1, $cop2, ..])
169 that lists its methods.
171 * We make CoreUnfold.exprIsConApp_maybe spot a DFunUnfolding and return
172 a suitable constructor application -- inlining df "on the fly" as it
175 * We give the ClassOp 'op2' a BuiltinRule that extracts the right piece
176 iff its argument satisfies exprIsConApp_maybe. This is done in
179 * We make 'df' CONLIKE, so that shared uses stil match; eg
181 in ...(op2 d)...(op1 d)...
183 Note [Single-method classes]
184 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
185 If the class has just one method (or, more accurately, just one element
186 of {superclasses + methods}), then we use a different strategy.
188 class C a where op :: a -> a
189 instance C a => C [a] where op = <blah>
191 We translate the class decl into a newtype, which just gives a
192 top-level axiom. The "constructor" MkC expands to a cast, as does the
195 axiom Co:C a :: C a ~ (a->a)
197 op :: forall a. C a -> (a -> a)
198 op a d = d |> (Co:C a)
200 MkC :: forall a. (a->a) -> C a
201 MkC = /\a.\op. op |> (sym Co:C a)
203 The clever RULE stuff doesn't work now, because ($df a d) isn't
204 a constructor application, so exprIsConApp_maybe won't return
207 Instead, we simply rely on the fact that casts are cheap:
209 $df :: forall a. C a => C [a]
210 {-# INLINE df #} -- NB: INLINE this
211 $df = /\a. \d. MkC [a] ($cop_list a d)
212 = $cop_list |> forall a. C a -> (sym (Co:C [a]))
214 $cop_list :: forall a. C a => [a] -> [a]
219 we'll inline 'op' and '$df', since both are simply casts, and
222 Why do we use this different strategy? Because otherwise we
223 end up with non-inlined dictionaries that look like
225 which adds an extra indirection to every use, which seems stupid. See
226 Trac #4138 for an example (although the regression reported there
227 wasn't due to the indirction).
229 There is an awkward wrinkle though: we want to be very
231 instance C a => C [a] where
234 then we'll get an INLINE pragma on $cop_list but it's important that
235 $cop_list only inlines when it's applied to *two* arguments (the
236 dictionary and the list argument). So we nust not eta-expand $df
237 above. We ensure that this doesn't happen by putting an INLINE
238 pragma on the dfun itself; after all, it ends up being just a cast.
240 There is one more dark corner to the INLINE story, even more deeply
241 buried. Consider this (Trac #3772):
243 class DeepSeq a => C a where
246 instance C a => C [a] where
249 class DeepSeq a where
250 deepSeq :: a -> b -> b
252 instance DeepSeq a => DeepSeq [a] where
253 {-# INLINE deepSeq #-}
254 deepSeq xs b = foldr deepSeq b xs
256 That gives rise to these defns:
258 $cdeepSeq :: DeepSeq a -> [a] -> b -> b
259 -- User INLINE( 3 args )!
260 $cdeepSeq a (d:DS a) b (x:[a]) (y:b) = ...
262 $fDeepSeq[] :: DeepSeq a -> DeepSeq [a]
263 -- DFun (with auto INLINE pragma)
264 $fDeepSeq[] a d = $cdeepSeq a d |> blah
266 $cp1 a d :: C a => DeepSep [a]
267 -- We don't want to eta-expand this, lest
268 -- $cdeepSeq gets inlined in it!
269 $cp1 a d = $fDeepSep[] a (scsel a d)
271 $fC[] :: C a => C [a]
273 $fC[] a d = MkC ($cp1 a d) ($cgen a d)
275 Here $cp1 is the code that generates the superclass for C [a]. The
276 issue is this: we must not eta-expand $cp1 either, or else $fDeepSeq[]
277 and then $cdeepSeq will inline there, which is definitely wrong. Like
278 on the dfun, we solve this by adding an INLINE pragma to $cp1.
280 Note [Subtle interaction of recursion and overlap]
281 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
283 class C a where { op1,op2 :: a -> a }
284 instance C a => C [a] where
285 op1 x = op2 x ++ op2 x
287 instance C [Int] where
290 When type-checking the C [a] instance, we need a C [a] dictionary (for
291 the call of op2). If we look up in the instance environment, we find
292 an overlap. And in *general* the right thing is to complain (see Note
293 [Overlapping instances] in InstEnv). But in *this* case it's wrong to
294 complain, because we just want to delegate to the op2 of this same
297 Why is this justified? Because we generate a (C [a]) constraint in
298 a context in which 'a' cannot be instantiated to anything that matches
299 other overlapping instances, or else we would not be excecuting this
300 version of op1 in the first place.
302 It might even be a bit disguised:
304 nullFail :: C [a] => [a] -> [a]
305 nullFail x = op2 x ++ op2 x
307 instance C a => C [a] where
310 Precisely this is used in package 'regex-base', module Context.hs.
311 See the overlapping instances for RegexContext, and the fact that they
312 call 'nullFail' just like the example above. The DoCon package also
313 does the same thing; it shows up in module Fraction.hs
315 Conclusion: when typechecking the methods in a C [a] instance, we want to
316 treat the 'a' as an *existential* type variable, in the sense described
317 by Note [Binding when looking up instances]. That is why isOverlappableTyVar
318 responds True to an InstSkol, which is the kind of skolem we use in
322 Note [Tricky type variable scoping]
323 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
326 op1, op2 :: Ix b => a -> b -> b
329 instance C a => C [a]
330 {-# INLINE [2] op1 #-}
333 note that 'a' and 'b' are *both* in scope in <dm-rhs>, but only 'a' is
334 in scope in <rhs>. In particular, we must make sure that 'b' is in
335 scope when typechecking <dm-rhs>. This is achieved by subFunTys,
336 which brings appropriate tyvars into scope. This happens for both
337 <dm-rhs> and for <rhs>, but that doesn't matter: the *renamer* will have
338 complained if 'b' is mentioned in <rhs>.
342 %************************************************************************
344 \subsection{Extracting instance decls}
346 %************************************************************************
348 Gather up the instance declarations from their various sources
351 tcInstDecls1 -- Deal with both source-code and imported instance decls
352 :: [LTyClDecl Name] -- For deriving stuff
353 -> [LInstDecl Name] -- Source code instance decls
354 -> [LDerivDecl Name] -- Source code stand-alone deriving decls
355 -> TcM (TcGblEnv, -- The full inst env
356 [InstInfo Name], -- Source-code instance decls to process;
357 -- contains all dfuns for this module
358 HsValBinds Name) -- Supporting bindings for derived instances
360 tcInstDecls1 tycl_decls inst_decls deriv_decls
362 do { -- Stop if addInstInfos etc discovers any errors
363 -- (they recover, so that we get more than one error each
366 -- (1) Do class and family instance declarations
367 ; idx_tycons <- mapAndRecoverM (tcFamInstDecl TopLevel) $
368 filter (isFamInstDecl . unLoc) tycl_decls
369 ; local_info_tycons <- mapAndRecoverM tcLocalInstDecl1 inst_decls
372 at_tycons_s) = unzip local_info_tycons
373 ; at_idx_tycons = concat at_tycons_s ++ idx_tycons
374 ; clas_decls = filter (isClassDecl.unLoc) tycl_decls
375 ; implicit_things = concatMap implicitTyThings at_idx_tycons
376 ; aux_binds = mkRecSelBinds at_idx_tycons
379 -- (2) Add the tycons of indexed types and their implicit
380 -- tythings to the global environment
381 ; tcExtendGlobalEnv (at_idx_tycons ++ implicit_things) $ do {
383 -- (3) Instances from generic class declarations
384 ; generic_inst_info <- getGenericInstances clas_decls
386 -- Next, construct the instance environment so far, consisting
388 -- (a) local instance decls
389 -- (b) generic instances
390 -- (c) local family instance decls
391 ; addInsts local_info $
392 addInsts generic_inst_info $
393 addFamInsts at_idx_tycons $ do {
395 -- (4) Compute instances from "deriving" clauses;
396 -- This stuff computes a context for the derived instance
397 -- decl, so it needs to know about all the instances possible
398 -- NB: class instance declarations can contain derivings as
399 -- part of associated data type declarations
400 failIfErrsM -- If the addInsts stuff gave any errors, don't
401 -- try the deriving stuff, becuase that may give
403 ; (deriv_inst_info, deriv_binds, deriv_dus)
404 <- tcDeriving tycl_decls inst_decls deriv_decls
405 ; gbl_env <- addInsts deriv_inst_info getGblEnv
406 ; return ( addTcgDUs gbl_env deriv_dus,
407 generic_inst_info ++ deriv_inst_info ++ local_info,
408 aux_binds `plusHsValBinds` deriv_binds)
411 addInsts :: [InstInfo Name] -> TcM a -> TcM a
412 addInsts infos thing_inside
413 = tcExtendLocalInstEnv (map iSpec infos) thing_inside
415 addFamInsts :: [TyThing] -> TcM a -> TcM a
416 addFamInsts tycons thing_inside
417 = tcExtendLocalFamInstEnv (map mkLocalFamInstTyThing tycons) thing_inside
419 mkLocalFamInstTyThing (ATyCon tycon) = mkLocalFamInst tycon
420 mkLocalFamInstTyThing tything = pprPanic "TcInstDcls.addFamInsts"
425 tcLocalInstDecl1 :: LInstDecl Name
426 -> TcM (InstInfo Name, [TyThing])
427 -- A source-file instance declaration
428 -- Type-check all the stuff before the "where"
430 -- We check for respectable instance type, and context
431 tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats))
433 addErrCtxt (instDeclCtxt1 poly_ty) $
435 do { is_boot <- tcIsHsBoot
436 ; checkTc (not is_boot || (isEmptyLHsBinds binds && null uprags))
439 ; (tyvars, theta, clas, inst_tys) <- tcHsInstHead poly_ty
440 ; checkValidInstance poly_ty tyvars theta clas inst_tys
442 -- Next, process any associated types.
443 ; idx_tycons <- recoverM (return []) $
444 do { idx_tycons <- checkNoErrs $
445 mapAndRecoverM (tcFamInstDecl NotTopLevel) ats
446 ; checkValidAndMissingATs clas (tyvars, inst_tys)
448 ; return idx_tycons }
450 -- Finally, construct the Core representation of the instance.
451 -- (This no longer includes the associated types.)
452 ; dfun_name <- newDFunName clas inst_tys (getLoc poly_ty)
453 -- Dfun location is that of instance *header*
454 ; overlap_flag <- getOverlapFlag
455 ; let (eq_theta,dict_theta) = partition isEqPred theta
456 theta' = eq_theta ++ dict_theta
457 dfun = mkDictFunId dfun_name tyvars theta' clas inst_tys
458 ispec = mkLocalInstance dfun overlap_flag
460 ; return (InstInfo { iSpec = ispec, iBinds = VanillaInst binds uprags False },
464 -- We pass in the source form and the type checked form of the ATs. We
465 -- really need the source form only to be able to produce more informative
467 checkValidAndMissingATs :: Class
468 -> ([TyVar], [TcType]) -- instance types
469 -> [(LTyClDecl Name, -- source form of AT
470 TyThing)] -- Core form of AT
472 checkValidAndMissingATs clas inst_tys ats
473 = do { -- Issue a warning for each class AT that is not defined in this
475 ; let class_ats = map tyConName (classATs clas)
476 defined_ats = listToNameSet . map (tcdName.unLoc.fst) $ ats
477 omitted = filterOut (`elemNameSet` defined_ats) class_ats
478 ; warn <- doptM Opt_WarnMissingMethods
479 ; mapM_ (warnTc warn . omittedATWarn) omitted
481 -- Ensure that all AT indexes that correspond to class parameters
482 -- coincide with the types in the instance head. All remaining
483 -- AT arguments must be variables. Also raise an error for any
484 -- type instances that are not associated with this class.
485 ; mapM_ (checkIndexes clas inst_tys) ats
488 checkIndexes clas inst_tys (hsAT, ATyCon tycon)
489 -- !!!TODO: check that this does the Right Thing for indexed synonyms, too!
490 = checkIndexes' clas inst_tys hsAT
492 snd . fromJust . tyConFamInst_maybe $ tycon)
493 checkIndexes _ _ _ = panic "checkIndexes"
495 checkIndexes' clas (instTvs, instTys) hsAT (atTvs, atTys)
496 = let atName = tcdName . unLoc $ hsAT
498 setSrcSpan (getLoc hsAT) $
499 addErrCtxt (atInstCtxt atName) $
500 case find ((atName ==) . tyConName) (classATs clas) of
501 Nothing -> addErrTc $ badATErr clas atName -- not in this class
503 -- The following is tricky! We need to deal with three
504 -- complications: (1) The AT possibly only uses a subset of
505 -- the class parameters as indexes and those it uses may be in
506 -- a different order; (2) the AT may have extra arguments,
507 -- which must be type variables; and (3) variables in AT and
508 -- instance head will be different `Name's even if their
509 -- source lexemes are identical.
511 -- e.g. class C a b c where
512 -- data D b a :: * -> * -- NB (1) b a, omits c
513 -- instance C [x] Bool Char where
514 -- data D Bool [x] v = MkD x [v] -- NB (2) v
515 -- -- NB (3) the x in 'instance C...' have differnt
516 -- -- Names to x's in 'data D...'
518 -- Re (1), `poss' contains a permutation vector to extract the
519 -- class parameters in the right order.
521 -- Re (2), we wrap the (permuted) class parameters in a Maybe
522 -- type and use Nothing for any extra AT arguments. (First
523 -- equation of `checkIndex' below.)
525 -- Re (3), we replace any type variable in the AT parameters
526 -- that has the same source lexeme as some variable in the
527 -- instance types with the instance type variable sharing its
531 -- For *associated* type families, gives the position
532 -- of that 'TyVar' in the class argument list (0-indexed)
533 -- e.g. class C a b c where { type F c a :: *->* }
534 -- Then we get Just [2,0]
535 poss = catMaybes [ tv `elemIndex` classTyVars clas
536 | tv <- tyConTyVars atycon]
537 -- We will get Nothings for the "extra" type
538 -- variables in an associated data type
539 -- e.g. class C a where { data D a :: *->* }
540 -- here D gets arity 2 and has two tyvars
542 relevantInstTys = map (instTys !!) poss
543 instArgs = map Just relevantInstTys ++
544 repeat Nothing -- extra arguments
545 renaming = substSameTyVar atTvs instTvs
547 zipWithM_ checkIndex (substTys renaming atTys) instArgs
549 checkIndex ty Nothing
550 | isTyVarTy ty = return ()
551 | otherwise = addErrTc $ mustBeVarArgErr ty
552 checkIndex ty (Just instTy)
553 | ty `tcEqType` instTy = return ()
554 | otherwise = addErrTc $ wrongATArgErr ty instTy
556 listToNameSet = addListToNameSet emptyNameSet
558 substSameTyVar [] _ = emptyTvSubst
559 substSameTyVar (tv:tvs) replacingTvs =
560 let replacement = case find (tv `sameLexeme`) replacingTvs of
561 Nothing -> mkTyVarTy tv
562 Just rtv -> mkTyVarTy rtv
564 tv1 `sameLexeme` tv2 =
565 nameOccName (tyVarName tv1) == nameOccName (tyVarName tv2)
567 extendTvSubst (substSameTyVar tvs replacingTvs) tv replacement
571 %************************************************************************
573 Type-checking instance declarations, pass 2
575 %************************************************************************
578 tcInstDecls2 :: [LTyClDecl Name] -> [InstInfo Name]
580 -- (a) From each class declaration,
581 -- generate any default-method bindings
582 -- (b) From each instance decl
583 -- generate the dfun binding
585 tcInstDecls2 tycl_decls inst_decls
586 = do { -- (a) Default methods from class decls
587 let class_decls = filter (isClassDecl . unLoc) tycl_decls
588 ; dm_binds_s <- mapM tcClassDecl2 class_decls
589 ; let dm_binds = unionManyBags dm_binds_s
591 -- (b) instance declarations
592 ; let dm_ids = collectHsBindsBinders dm_binds
593 -- Add the default method Ids (again)
594 -- See Note [Default methods and instances]
595 ; inst_binds_s <- tcExtendIdEnv dm_ids $
596 mapM tcInstDecl2 inst_decls
599 ; return (dm_binds `unionBags` unionManyBags inst_binds_s) }
602 See Note [Default methods and instances]
603 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
604 The default method Ids are already in the type environment (see Note
605 [Default method Ids and Template Haskell] in TcTyClsDcls), BUT they
606 don't have their InlinePragmas yet. Usually that would not matter,
607 because the simplifier propagates information from binding site to
608 use. But, unusually, when compiling instance decls we *copy* the
609 INLINE pragma from the default method to the method for that
610 particular operation (see Note [INLINE and default methods] below).
612 So right here in tcInstDecl2 we must re-extend the type envt with
613 the default method Ids replete with their INLINE pragmas. Urk.
617 tcInstDecl2 :: InstInfo Name -> TcM (LHsBinds Id)
618 -- Returns a binding for the dfun
619 tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
620 = recoverM (return emptyLHsBinds) $
622 addErrCtxt (instDeclCtxt2 (idType dfun_id)) $
623 do { -- Instantiate the instance decl with skolem constants
624 ; (inst_tyvars, dfun_theta, inst_head) <- tcSkolSigType skol_info (idType dfun_id)
625 ; let (clas, inst_tys) = tcSplitDFunHead inst_head
626 (class_tyvars, sc_theta, _, op_items) = classBigSig clas
627 sc_theta' = substTheta (zipOpenTvSubst class_tyvars inst_tys) sc_theta
628 n_ty_args = length inst_tyvars
629 n_silent = dfunNSilent dfun_id
630 (silent_theta, orig_theta) = splitAt n_silent dfun_theta
632 ; silent_ev_vars <- mapM newSilentGiven silent_theta
633 ; orig_ev_vars <- newEvVars orig_theta
634 ; let dfun_ev_vars = silent_ev_vars ++ orig_ev_vars
636 ; (sc_binds, sc_dicts, sc_args)
637 <- mapAndUnzip3M (tcSuperClass n_ty_args dfun_ev_vars) sc_theta'
639 -- Check that any superclasses gotten from a silent arguemnt
640 -- can be deduced from the originally-specified dfun arguments
641 ; ct_loc <- getCtLoc ScOrigin
642 ; _ <- checkConstraints skol_info inst_tyvars orig_ev_vars $
643 emitConstraints $ listToBag $
644 [ WcEvVar (WantedEvVar sc ct_loc)
645 | sc <- sc_dicts, isSilentEvVar sc ]
647 -- Deal with 'SPECIALISE instance' pragmas
648 -- See Note [SPECIALISE instance pragmas]
649 ; spec_info <- tcSpecInstPrags dfun_id ibinds
651 -- Typecheck the methods
652 ; (meth_ids, meth_binds)
653 <- tcExtendTyVarEnv inst_tyvars $
654 -- The inst_tyvars scope over the 'where' part
655 -- Those tyvars are inside the dfun_id's type, which is a bit
656 -- bizarre, but OK so long as you realise it!
657 tcInstanceMethods dfun_id clas inst_tyvars dfun_ev_vars
661 -- Create the result bindings
662 ; let dict_constr = classDataCon clas
663 dict_bind = mkVarBind self_dict dict_rhs
664 dict_rhs = foldl mk_app inst_constr $
665 map HsVar sc_dicts ++ map (wrapId arg_wrapper) meth_ids
666 inst_constr = L loc $ wrapId (mkWpTyApps inst_tys)
667 (dataConWrapId dict_constr)
668 -- We don't produce a binding for the dict_constr; instead we
669 -- rely on the simplifier to unfold this saturated application
670 -- We do this rather than generate an HsCon directly, because
671 -- it means that the special cases (e.g. dictionary with only one
672 -- member) are dealt with by the common MkId.mkDataConWrapId
673 -- code rather than needing to be repeated here.
675 mk_app :: LHsExpr Id -> Id -> LHsExpr Id
676 mk_app fun arg_id = L loc (HsApp fun (L loc (wrapId arg_wrapper arg_id)))
677 arg_wrapper = mkWpEvVarApps dfun_ev_vars <.> mkWpTyApps (mkTyVarTys inst_tyvars')
679 -- Do not inline the dfun; instead give it a magic DFunFunfolding
680 -- See Note [ClassOp/DFun selection]
681 -- See also note [Single-method classes]
682 dfun_id_w_fun = dfun_id
683 `setIdUnfolding` mkDFunUnfolding inst_ty (map Var dict_and_meth_ids)
684 -- Not right for equality superclasses
685 `setInlinePragma` dfunInlinePragma
687 main_bind = AbsBinds { abs_tvs = inst_tyvars
688 , abs_ev_vars = dfun_ev_vars
689 , abs_exports = [(inst_tyvars, dfun_id_w_fun, self_dict,
690 SpecPrags [] {- spec_inst_prags -})]
691 , abs_ev_binds = emptyTcEvBinds
692 , abs_binds = unitBag dict_bind }
694 ; return (unitBag (L loc main_bind) `unionBags`
695 unionManyBags sc_binds `unionBags`
696 listToBag meth_binds)
699 skol_info = InstSkol -- See Note [Subtle interaction of recursion and overlap]
700 dfun_ty = idType dfun_id
701 dfun_id = instanceDFunId ispec
702 loc = getSrcSpan dfun_id
704 ------------------------------
705 tcSuperClass :: Int -> [EvVar] -> PredType -> TcM (LHsBinds Id, Id, DFunArg CoreExpr)
706 tcSuperClass n_ty_args ev_vars pred
707 | Just (ev, i) <- find n_ty_args ev_vars
708 = return (emptyBag, ev, DFunLamArg i)
710 = ASSERT2( isEmptyVarSet (tyVarsOfPred pred), ppr pred)
711 do { sc_dict <- newWantedEvVar pred
712 ; loc <- getCtLoc ScOrigin
713 ; ev_binds <- simplifyTop (unitBag (WcEvVar (WantedEvVar sc_dict loc)))
714 ; let ev_wrap = WpLet (EvBinds ev_binds)
715 sc_bind = mkVarBind sc_dict (noLoc $ (wrapId ev_wrap sc_dict))
716 ; return (unitBag sc_bind, sc_dict, DFunConstArg (Var sc_dict)) }
717 -- It's very important to solve the superclass constraint *in isolation*
718 -- so that it isn't generated by superclass selection from something else
719 -- We then generate the (also rather degenerate) top-level binding:
720 -- sc_dict = let sc_dict = <blah> in sc_dict
721 -- where <blah> is generated by solving the implication constraint
724 find i (ev:evs) | pred `tcEqPred` evVarPred ev = Just (ev, i)
725 | otherwise = find (i+1) evs
727 ------------------------------
728 tcSpecInstPrags :: DFunId -> InstBindings Name
729 -> TcM ([Located TcSpecPrag], PragFun)
730 tcSpecInstPrags _ (NewTypeDerived {})
731 = return ([], \_ -> [])
732 tcSpecInstPrags dfun_id (VanillaInst binds uprags _)
733 = do { spec_inst_prags <- mapM (wrapLocM (tcSpecInst dfun_id)) $
734 filter isSpecInstLSig uprags
735 -- The filter removes the pragmas for methods
736 ; return (spec_inst_prags, mkPragFun uprags binds) }
739 Note [Silent Superclass Arguments]
740 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
741 Consider the following (extreme) situation:
742 class C a => D a where ...
743 instance D [a] => D [a] where ...
744 Although this looks wrong (assume D [a] to prove D [a]), it is only a
745 more extreme case of what happens with recursive dictionaries.
748 ; let sc_op_ty = mkForAllTys tyvars $ mkPiTypes dicts (varType sc_dict)
749 sc_op_name = mkDerivedInternalName mkClassOpAuxOcc uniq
751 sc_op_id = mkLocalId sc_op_name sc_op_ty
752 sc_op_bind = VarBind { var_id = sc_op_id, var_inline = False
753 , var_rhs = L noSrcSpan $ wrapId sc_wrapper sc_dict }
754 sc_wrapper = mkWpTyLams tyvars
758 However this means that if we later encounter a situation where
759 we have a [Wanted] dw::D [a] we could solve it thus:
761 Although recursive, this binding would pass the TcSMonadisGoodRecEv
762 check because it appears as guarded. But in reality, it will make a
763 bottom superclass. The trouble is that isGoodRecEv can't "see" the
764 superclass-selection inside dfun.
766 Our solution to this problem is to change the way ‘dfuns’ are created
767 for instances, so that we pass as first arguments to the dfun some
768 ``silent superclass arguments’’, which are the immediate superclasses
769 of the dictionary we are trying to construct. In our example:
770 dfun :: forall a. (C [a], D [a] -> D [a]
771 dfun = \(dc::C [a]) (dd::D [a]) -> DOrd dc ...
775 -----------------------------------------------------------
776 DFun Superclass Invariant
777 ~~~~~~~~~~~~~~~~~~~~~~~~
778 In the body of a DFun, every superclass argument to the
779 returned dictionary is
780 either * one of the arguments of the DFun,
781 or * constant, bound at top level
782 -----------------------------------------------------------
784 This means that no superclass is hidden inside a dfun application, so
785 the counting argument in isGoodRecEv (more dfun calls than superclass
786 selections) works correctly.
788 The extra arguments required to satisfy the DFun Superclass Invariant
789 always come first, and are called the "silent" arguments. DFun types
790 are built (only) by MkId.mkDictFunId, so that is where we decide
791 what silent arguments are to be added.
793 This net effect is that it is safe to treat a dfun application as
794 wrapping a dictionary constructor around its arguments (in particular,
795 a dfun never picks superclasses from the arguments under the dictionary
798 In our example, if we had [Wanted] dw :: D [a] we would get via the instance:
800 [Wanted] (d1 :: C [a])
801 [Wanted] (d2 :: D [a])
802 [Derived] (d :: D [a])
803 [Derived] (scd :: C [a]) scd := scsel d
804 [Derived] (scd2 :: C [a]) scd2 := scsel d2
806 And now, though we *can* solve:
808 we will get an isGoodRecEv failure when we try to solve:
813 Test case SCLoop tests this fix.
815 Note [SPECIALISE instance pragmas]
816 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
819 instance (Ix a, Ix b) => Ix (a,b) where
820 {-# SPECIALISE instance Ix (Int,Int) #-}
823 We do *not* want to make a specialised version of the dictionary
824 function. Rather, we want specialised versions of each method.
825 Thus we should generate something like this:
827 $dfIx :: (Ix a, Ix x) => Ix (a,b)
828 {- DFUN [$crange, ...] -}
829 $dfIx da db = Ix ($crange da db) (...other methods...)
831 $dfIxPair :: (Ix a, Ix x) => Ix (a,b)
832 {- DFUN [$crangePair, ...] -}
833 $dfIxPair = Ix ($crangePair da db) (...other methods...)
835 $crange :: (Ix a, Ix b) -> ((a,b),(a,b)) -> [(a,b)]
836 {-# SPECIALISE $crange :: ((Int,Int),(Int,Int)) -> [(Int,Int)] #-}
837 $crange da db = <blah>
839 {-# RULE range ($dfIx da db) = $crange da db #-}
843 * The RULE is unaffected by the specialisation. We don't want to
844 specialise $dfIx, because then it would need a specialised RULE
845 which is a pain. The single RULE works fine at all specialisations.
846 See Note [How instance declarations are translated] above
848 * Instead, we want to specialise the *method*, $crange
850 In practice, rather than faking up a SPECIALISE pragama for each
851 method (which is painful, since we'd have to figure out its
852 specialised type), we call tcSpecPrag *as if* were going to specialise
853 $dfIx -- you can see that in the call to tcSpecInst. That generates a
854 SpecPrag which, as it turns out, can be used unchanged for each method.
855 The "it turns out" bit is delicate, but it works fine!
858 tcSpecInst :: Id -> Sig Name -> TcM TcSpecPrag
859 tcSpecInst dfun_id prag@(SpecInstSig hs_ty)
860 = addErrCtxt (spec_ctxt prag) $
861 do { let name = idName dfun_id
862 ; (tyvars, theta, clas, tys) <- tcHsInstHead hs_ty
863 ; let (_, spec_dfun_ty) = mkDictFunTy tyvars theta clas tys
865 ; co_fn <- tcSubType (SpecPragOrigin name) (SigSkol SpecInstCtxt)
866 (idType dfun_id) spec_dfun_ty
867 ; return (SpecPrag dfun_id co_fn defaultInlinePragma) }
869 spec_ctxt prag = hang (ptext (sLit "In the SPECIALISE pragma")) 2 (ppr prag)
871 tcSpecInst _ _ = panic "tcSpecInst"
874 %************************************************************************
876 Type-checking an instance method
878 %************************************************************************
881 - Make the method bindings, as a [(NonRec, HsBinds)], one per method
882 - Remembering to use fresh Name (the instance method Name) as the binder
883 - Bring the instance method Ids into scope, for the benefit of tcInstSig
884 - Use sig_fn mapping instance method Name -> instance tyvars
886 - Use tcValBinds to do the checking
889 tcInstanceMethods :: DFunId -> Class -> [TcTyVar]
892 -> ([Located TcSpecPrag], PragFun)
895 -> TcM ([Id], [LHsBind Id])
896 -- The returned inst_meth_ids all have types starting
897 -- forall tvs. theta => ...
898 tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
899 (spec_inst_prags, prag_fn)
900 op_items (VanillaInst binds _ standalone_deriv)
901 = mapAndUnzipM tc_item op_items
903 ----------------------
904 tc_item :: (Id, DefMeth) -> TcM (Id, LHsBind Id)
905 tc_item (sel_id, dm_info)
906 = case findMethodBind (idName sel_id) binds of
907 Just user_bind -> tc_body sel_id standalone_deriv user_bind
908 Nothing -> tc_default sel_id dm_info
910 ----------------------
911 tc_body :: Id -> Bool -> LHsBind Name -> TcM (TcId, LHsBind Id)
912 tc_body sel_id generated_code rn_bind
913 = add_meth_ctxt sel_id generated_code rn_bind $
914 do { (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars
916 ; let prags = prag_fn (idName sel_id)
917 ; meth_id1 <- addInlinePrags meth_id prags
918 ; spec_prags <- tcSpecPrags meth_id1 prags
919 ; bind <- tcInstanceMethodBody InstSkol
921 meth_id1 local_meth_id meth_sig_fn
922 (mk_meth_spec_prags meth_id1 spec_prags)
924 ; return (meth_id1, bind) }
926 ----------------------
927 tc_default :: Id -> DefMeth -> TcM (TcId, LHsBind Id)
928 tc_default sel_id GenDefMeth -- Derivable type classes stuff
929 = do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id
930 ; tc_body sel_id False {- Not generated code? -} meth_bind }
932 tc_default sel_id NoDefMeth -- No default method at all
933 = do { warnMissingMethod sel_id
934 ; (meth_id, _) <- mkMethIds clas tyvars dfun_ev_vars
936 ; return (meth_id, mkVarBind meth_id $
937 mkLHsWrap lam_wrapper error_rhs) }
939 error_rhs = L loc $ HsApp error_fun error_msg
940 error_fun = L loc $ wrapId (WpTyApp meth_tau) nO_METHOD_BINDING_ERROR_ID
941 error_msg = L loc (HsLit (HsStringPrim (mkFastString error_string)))
942 meth_tau = funResultTy (applyTys (idType sel_id) inst_tys)
943 error_string = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
944 lam_wrapper = mkWpTyLams tyvars <.> mkWpLams dfun_ev_vars
946 tc_default sel_id (DefMeth dm_name) -- A polymorphic default method
947 = do { -- Build the typechecked version directly,
948 -- without calling typecheck_method;
949 -- see Note [Default methods in instances]
950 -- Generate /\as.\ds. let self = df as ds
951 -- in $dm inst_tys self
952 -- The 'let' is necessary only because HsSyn doesn't allow
953 -- you to apply a function to a dictionary *expression*.
955 ; self_dict <- newEvVar (ClassP clas inst_tys)
956 ; let self_ev_bind = EvBind self_dict $
957 EvDFunApp dfun_id (mkTyVarTys tyvars) dfun_ev_vars
959 ; (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars
961 ; dm_id <- tcLookupId dm_name
962 ; let dm_inline_prag = idInlinePragma dm_id
963 rhs = HsWrap (mkWpEvVarApps [self_dict] <.> mkWpTyApps inst_tys) $
966 meth_bind = L loc $ VarBind { var_id = local_meth_id
967 , var_rhs = L loc rhs
968 , var_inline = False }
969 meth_id1 = meth_id `setInlinePragma` dm_inline_prag
970 -- Copy the inline pragma (if any) from the default
971 -- method to this version. Note [INLINE and default methods]
973 bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars
974 , abs_exports = [( tyvars, meth_id1, local_meth_id
975 , mk_meth_spec_prags meth_id1 [])]
976 , abs_ev_binds = EvBinds (unitBag self_ev_bind)
977 , abs_binds = unitBag meth_bind }
978 -- Default methods in an instance declaration can't have their own
979 -- INLINE or SPECIALISE pragmas. It'd be possible to allow them, but
980 -- currently they are rejected with
981 -- "INLINE pragma lacks an accompanying binding"
983 ; return (meth_id1, L loc bind) }
985 ----------------------
986 mk_meth_spec_prags :: Id -> [LTcSpecPrag] -> TcSpecPrags
987 -- Adapt the SPECIALISE pragmas to work for this method Id
988 -- There are two sources:
989 -- * spec_inst_prags: {-# SPECIALISE instance :: <blah> #-}
990 -- These ones have the dfun inside, but [perhaps surprisingly]
991 -- the correct wrapper
992 -- * spec_prags_for_me: {-# SPECIALISE op :: <blah> #-}
993 mk_meth_spec_prags meth_id spec_prags_for_me
994 = SpecPrags (spec_prags_for_me ++
995 [ L loc (SpecPrag meth_id wrap inl)
996 | L loc (SpecPrag _ wrap inl) <- spec_inst_prags])
998 loc = getSrcSpan dfun_id
999 meth_sig_fn _ = Just ([],loc) -- The 'Just' says "yes, there's a type sig"
1000 -- But there are no scoped type variables from local_method_id
1001 -- Only the ones from the instance decl itself, which are already
1002 -- in scope. Example:
1003 -- class C a where { op :: forall b. Eq b => ... }
1004 -- instance C [c] where { op = <rhs> }
1005 -- In <rhs>, 'c' is scope but 'b' is not!
1007 -- For instance decls that come from standalone deriving clauses
1008 -- we want to print out the full source code if there's an error
1009 -- because otherwise the user won't see the code at all
1010 add_meth_ctxt sel_id generated_code rn_bind thing
1011 | generated_code = addLandmarkErrCtxt (derivBindCtxt sel_id clas inst_tys rn_bind) thing
1015 tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
1016 _ op_items (NewTypeDerived coi _)
1019 -- class Show b => Foo a b where
1020 -- op :: a -> b -> b
1021 -- newtype N a = MkN (Tree [a])
1022 -- deriving instance (Show p, Foo Int p) => Foo Int (N p)
1023 -- -- NB: standalone deriving clause means
1024 -- -- that the contex is user-specified
1025 -- Hence op :: forall a b. Foo a b => a -> b -> b
1027 -- We're going to make an instance like
1028 -- instance (Show p, Foo Int p) => Foo Int (N p)
1031 -- $copT :: forall p. (Show p, Foo Int p) => Int -> N p -> N p
1032 -- $copT p (d1:Show p) (d2:Foo Int p)
1033 -- = op Int (Tree [p]) rep_d |> op_co
1035 -- rep_d :: Foo Int (Tree [p]) = ...d1...d2...
1036 -- op_co :: (Int -> Tree [p] -> Tree [p]) ~ (Int -> T p -> T p)
1037 -- We get op_co by substituting [Int/a] and [co/b] in type for op
1038 -- where co : [p] ~ T p
1040 -- Notice that the dictionary bindings "..d1..d2.." must be generated
1041 -- by the constraint solver, since the <context> may be
1044 = do { rep_d_stuff <- checkConstraints InstSkol tyvars dfun_ev_vars $
1045 emitWanted ScOrigin rep_pred
1047 ; mapAndUnzipM (tc_item rep_d_stuff) op_items }
1049 loc = getSrcSpan dfun_id
1051 inst_tvs = fst (tcSplitForAllTys (idType dfun_id))
1052 Just (init_inst_tys, _) = snocView inst_tys
1053 rep_ty = fst (coercionKind co) -- [p]
1054 rep_pred = mkClassPred clas (init_inst_tys ++ [rep_ty])
1057 co = substTyWith inst_tvs (mkTyVarTys tyvars) $
1058 case coi of { IdCo ty -> ty ;
1059 ACo co -> mkSymCoercion co }
1062 tc_item :: (TcEvBinds, EvVar) -> (Id, DefMeth) -> TcM (TcId, LHsBind TcId)
1063 tc_item (rep_ev_binds, rep_d) (sel_id, _)
1064 = do { (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars
1067 ; let meth_rhs = wrapId (mk_op_wrapper sel_id rep_d) sel_id
1068 meth_bind = VarBind { var_id = local_meth_id
1069 , var_rhs = L loc meth_rhs
1070 , var_inline = False }
1072 bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars
1073 , abs_exports = [(tyvars, meth_id,
1074 local_meth_id, noSpecPrags)]
1075 , abs_ev_binds = rep_ev_binds
1076 , abs_binds = unitBag $ L loc meth_bind }
1078 ; return (meth_id, L loc bind) }
1081 mk_op_wrapper :: Id -> EvVar -> HsWrapper
1082 mk_op_wrapper sel_id rep_d
1083 = WpCast (substTyWith sel_tvs (init_inst_tys ++ [co]) local_meth_ty)
1084 <.> WpEvApp (EvId rep_d)
1085 <.> mkWpTyApps (init_inst_tys ++ [rep_ty])
1087 (sel_tvs, sel_rho) = tcSplitForAllTys (idType sel_id)
1088 (_, local_meth_ty) = tcSplitPredFunTy_maybe sel_rho
1089 `orElse` pprPanic "tcInstanceMethods" (ppr sel_id)
1091 ----------------------
1092 mkMethIds :: Class -> [TcTyVar] -> [EvVar] -> [TcType] -> Id -> TcM (TcId, TcId)
1093 mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id
1094 = do { uniq <- newUnique
1095 ; let meth_name = mkDerivedInternalName mkClassOpAuxOcc uniq sel_name
1096 ; local_meth_name <- newLocalName sel_name
1097 -- Base the local_meth_name on the selector name, becuase
1098 -- type errors from tcInstanceMethodBody come from here
1100 ; let meth_id = mkLocalId meth_name meth_ty
1101 local_meth_id = mkLocalId local_meth_name local_meth_ty
1102 ; return (meth_id, local_meth_id) }
1104 local_meth_ty = instantiateMethod clas sel_id inst_tys
1105 meth_ty = mkForAllTys tyvars $ mkPiTypes dfun_ev_vars local_meth_ty
1106 sel_name = idName sel_id
1108 ----------------------
1109 wrapId :: HsWrapper -> id -> HsExpr id
1110 wrapId wrapper id = mkHsWrap wrapper (HsVar id)
1112 derivBindCtxt :: Id -> Class -> [Type ] -> LHsBind Name -> SDoc
1113 derivBindCtxt sel_id clas tys _bind
1114 = vcat [ ptext (sLit "When typechecking the code for ") <+> quotes (ppr sel_id)
1115 , nest 2 (ptext (sLit "in a standalone derived instance for")
1116 <+> quotes (pprClassPred clas tys) <> colon)
1117 , nest 2 $ ptext (sLit "To see the code I am typechecking, use -ddump-deriv") ]
1120 -- , nest 2 $ pprSetDepth AllTheWay $ ppr bind ]
1122 warnMissingMethod :: Id -> TcM ()
1123 warnMissingMethod sel_id
1124 = do { warn <- doptM Opt_WarnMissingMethods
1125 ; warnTc (warn -- Warn only if -fwarn-missing-methods
1126 && not (startsWithUnderscore (getOccName sel_id)))
1127 -- Don't warn about _foo methods
1128 (ptext (sLit "No explicit method nor default method for")
1129 <+> quotes (ppr sel_id)) }
1132 Note [Export helper functions]
1133 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1134 We arrange to export the "helper functions" of an instance declaration,
1135 so that they are not subject to preInlineUnconditionally, even if their
1136 RHS is trivial. Reason: they are mentioned in the DFunUnfolding of
1137 the dict fun as Ids, not as CoreExprs, so we can't substitute a
1138 non-variable for them.
1140 We could change this by making DFunUnfoldings have CoreExprs, but it
1141 seems a bit simpler this way.
1143 Note [Default methods in instances]
1144 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1151 instance Baz Int Int
1153 From the class decl we get
1155 $dmfoo :: forall v x. Baz v x => x -> x
1158 Notice that the type is ambiguous. That's fine, though. The instance
1161 $dBazIntInt = MkBaz fooIntInt
1162 fooIntInt = $dmfoo Int Int $dBazIntInt
1164 BUT this does mean we must generate the dictionary translation of
1165 fooIntInt directly, rather than generating source-code and
1166 type-checking it. That was the bug in Trac #1061. In any case it's
1167 less work to generate the translated version!
1169 Note [INLINE and default methods]
1170 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1171 Default methods need special case. They are supposed to behave rather like
1172 macros. For exmample
1175 op1, op2 :: Bool -> a -> a
1178 op1 b x = op2 (not b) x
1180 instance Foo Int where
1181 -- op1 via default method
1184 The instance declaration should behave
1186 just as if 'op1' had been defined with the
1187 code, and INLINE pragma, from its original
1190 That is, just as if you'd written
1192 instance Foo Int where
1196 op1 b x = op2 (not b) x
1198 So for the above example we generate:
1201 {-# INLINE $dmop1 #-}
1202 -- $dmop1 has an InlineCompulsory unfolding
1203 $dmop1 d b x = op2 d (not b) x
1205 $fFooInt = MkD $cop1 $cop2
1207 {-# INLINE $cop1 #-}
1208 $cop1 = $dmop1 $fFooInt
1214 * We *copy* any INLINE pragma from the default method $dmop1 to the
1215 instance $cop1. Otherwise we'll just inline the former in the
1216 latter and stop, which isn't what the user expected
1218 * Regardless of its pragma, we give the default method an
1219 unfolding with an InlineCompulsory source. That means
1220 that it'll be inlined at every use site, notably in
1221 each instance declaration, such as $cop1. This inlining
1222 must happen even though
1223 a) $dmop1 is not saturated in $cop1
1224 b) $cop1 itself has an INLINE pragma
1226 It's vital that $dmop1 *is* inlined in this way, to allow the mutual
1227 recursion between $fooInt and $cop1 to be broken
1229 * To communicate the need for an InlineCompulsory to the desugarer
1230 (which makes the Unfoldings), we use the IsDefaultMethod constructor
1234 %************************************************************************
1236 \subsection{Error messages}
1238 %************************************************************************
1241 instDeclCtxt1 :: LHsType Name -> SDoc
1242 instDeclCtxt1 hs_inst_ty
1243 = inst_decl_ctxt (case unLoc hs_inst_ty of
1244 HsForAllTy _ _ _ (L _ (HsPredTy pred)) -> ppr pred
1245 HsPredTy pred -> ppr pred
1246 _ -> ppr hs_inst_ty) -- Don't expect this
1247 instDeclCtxt2 :: Type -> SDoc
1248 instDeclCtxt2 dfun_ty
1249 = inst_decl_ctxt (ppr (mkClassPred cls tys))
1251 (_,cls,tys) = tcSplitDFunTy dfun_ty
1253 inst_decl_ctxt :: SDoc -> SDoc
1254 inst_decl_ctxt doc = ptext (sLit "In the instance declaration for") <+> quotes doc
1256 atInstCtxt :: Name -> SDoc
1257 atInstCtxt name = ptext (sLit "In the associated type instance for") <+>
1260 mustBeVarArgErr :: Type -> SDoc
1261 mustBeVarArgErr ty =
1262 sep [ ptext (sLit "Arguments that do not correspond to a class parameter") <+>
1263 ptext (sLit "must be variables")
1264 , ptext (sLit "Instead of a variable, found") <+> ppr ty
1267 wrongATArgErr :: Type -> Type -> SDoc
1268 wrongATArgErr ty instTy =
1269 sep [ ptext (sLit "Type indexes must match class instance head")
1270 , ptext (sLit "Found") <+> quotes (ppr ty)
1271 <+> ptext (sLit "but expected") <+> quotes (ppr instTy)