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 )
23 import MkCore ( nO_METHOD_BINDING_ERROR_ID )
26 import RnSource ( addTcgDUs )
27 import TcSimplify( simplifySuperClass )
36 import VarSet ( emptyVarSet )
37 import CoreUtils ( mkPiTypes )
38 import CoreUnfold ( mkDFunUnfolding )
39 import CoreSyn ( Expr(Var) )
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 still use the *same* 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
194 axiom Co:C a :: C a ~ (a->a)
196 op :: forall a. C a -> (a -> a)
197 op a d = d |> (Co:C a)
199 MkC :: forall a. (a->a) -> C a
200 MkC = /\a.\op. op |> (sym Co:C a)
202 df :: forall a. C a => C [a]
203 {-# NOINLINE df DFun[ $cop_list ] #-}
204 df = /\a. \d. MkC ($cop_list a d)
206 $cop_list :: forall a. C a => [a] -> [a]
209 The "constructor" MkC expands to a cast, as does the class-op selector.
210 The RULE works just like for multi-field dictionaries:
212 * (df a d) returns (Just (MkC,..,[$cop_list a d]))
213 to exprIsConApp_Maybe
215 * The RULE for op picks the right result
217 This is a bit of a hack, because (df a d) isn't *really* a constructor
218 application. But it works just fine in this case, exprIsConApp_maybe
219 is otherwise used only when we hit a case expression which will have
220 a real data constructor in it.
222 The biggest reason for doing it this way, apart from uniformity, is
223 that we want to be very careful when we have
224 instance C a => C [a] where
227 then we'll get an INLINE pragma on $cop_list but it's important that
228 $cop_list only inlines when it's applied to *two* arguments (the
229 dictionary and the list argument
231 The danger is that we'll get something like
232 op_list :: C a => [a] -> [a]
233 op_list = /\a.\d. $cop_list a d
234 and then we'll eta expand, and then we'll inline TOO EARLY. This happened in
235 Trac #3772 and I spent far too long fiddling around trying to fix it.
236 Look at the test for Trac #3772.
238 (Note: re-reading the above, I can't see how using the
239 uniform story solves the problem.)
241 Note [Subtle interaction of recursion and overlap]
242 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
244 class C a where { op1,op2 :: a -> a }
245 instance C a => C [a] where
246 op1 x = op2 x ++ op2 x
248 instance C [Int] where
251 When type-checking the C [a] instance, we need a C [a] dictionary (for
252 the call of op2). If we look up in the instance environment, we find
253 an overlap. And in *general* the right thing is to complain (see Note
254 [Overlapping instances] in InstEnv). But in *this* case it's wrong to
255 complain, because we just want to delegate to the op2 of this same
258 Why is this justified? Because we generate a (C [a]) constraint in
259 a context in which 'a' cannot be instantiated to anything that matches
260 other overlapping instances, or else we would not be excecuting this
261 version of op1 in the first place.
263 It might even be a bit disguised:
265 nullFail :: C [a] => [a] -> [a]
266 nullFail x = op2 x ++ op2 x
268 instance C a => C [a] where
271 Precisely this is used in package 'regex-base', module Context.hs.
272 See the overlapping instances for RegexContext, and the fact that they
273 call 'nullFail' just like the example above. The DoCon package also
274 does the same thing; it shows up in module Fraction.hs
276 Conclusion: when typechecking the methods in a C [a] instance, we want
277 to have C [a] available. That is why we have the strange local
278 definition for 'this' in the definition of op1_i in the example above.
279 We can typecheck the defintion of local_op1, and when doing tcSimplifyCheck
280 we supply 'this' as a given dictionary. Only needed, though, if there
281 are some type variables involved; otherwise there can be no overlap and
284 Note [Tricky type variable scoping]
285 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
288 op1, op2 :: Ix b => a -> b -> b
291 instance C a => C [a]
292 {-# INLINE [2] op1 #-}
295 note that 'a' and 'b' are *both* in scope in <dm-rhs>, but only 'a' is
296 in scope in <rhs>. In particular, we must make sure that 'b' is in
297 scope when typechecking <dm-rhs>. This is achieved by subFunTys,
298 which brings appropriate tyvars into scope. This happens for both
299 <dm-rhs> and for <rhs>, but that doesn't matter: the *renamer* will have
300 complained if 'b' is mentioned in <rhs>.
304 %************************************************************************
306 \subsection{Extracting instance decls}
308 %************************************************************************
310 Gather up the instance declarations from their various sources
313 tcInstDecls1 -- Deal with both source-code and imported instance decls
314 :: [LTyClDecl Name] -- For deriving stuff
315 -> [LInstDecl Name] -- Source code instance decls
316 -> [LDerivDecl Name] -- Source code stand-alone deriving decls
317 -> TcM (TcGblEnv, -- The full inst env
318 [InstInfo Name], -- Source-code instance decls to process;
319 -- contains all dfuns for this module
320 HsValBinds Name) -- Supporting bindings for derived instances
322 tcInstDecls1 tycl_decls inst_decls deriv_decls
324 do { -- Stop if addInstInfos etc discovers any errors
325 -- (they recover, so that we get more than one error each
328 -- (1) Do class and family instance declarations
329 ; idx_tycons <- mapAndRecoverM (tcFamInstDecl TopLevel) $
330 filter (isFamInstDecl . unLoc) tycl_decls
331 ; local_info_tycons <- mapAndRecoverM tcLocalInstDecl1 inst_decls
334 at_tycons_s) = unzip local_info_tycons
335 ; at_idx_tycons = concat at_tycons_s ++ idx_tycons
336 ; clas_decls = filter (isClassDecl.unLoc) tycl_decls
337 ; implicit_things = concatMap implicitTyThings at_idx_tycons
338 ; aux_binds = mkRecSelBinds at_idx_tycons
341 -- (2) Add the tycons of indexed types and their implicit
342 -- tythings to the global environment
343 ; tcExtendGlobalEnv (at_idx_tycons ++ implicit_things) $ do {
345 -- (3) Instances from generic class declarations
346 ; generic_inst_info <- getGenericInstances clas_decls
348 -- Next, construct the instance environment so far, consisting
350 -- (a) local instance decls
351 -- (b) generic instances
352 -- (c) local family instance decls
353 ; addInsts local_info $
354 addInsts generic_inst_info $
355 addFamInsts at_idx_tycons $ do {
357 -- (4) Compute instances from "deriving" clauses;
358 -- This stuff computes a context for the derived instance
359 -- decl, so it needs to know about all the instances possible
360 -- NB: class instance declarations can contain derivings as
361 -- part of associated data type declarations
362 failIfErrsM -- If the addInsts stuff gave any errors, don't
363 -- try the deriving stuff, becuase that may give
365 ; (deriv_inst_info, deriv_binds, deriv_dus)
366 <- tcDeriving tycl_decls inst_decls deriv_decls
367 ; gbl_env <- addInsts deriv_inst_info getGblEnv
368 ; return ( addTcgDUs gbl_env deriv_dus,
369 generic_inst_info ++ deriv_inst_info ++ local_info,
370 aux_binds `plusHsValBinds` deriv_binds)
373 addInsts :: [InstInfo Name] -> TcM a -> TcM a
374 addInsts infos thing_inside
375 = tcExtendLocalInstEnv (map iSpec infos) thing_inside
377 addFamInsts :: [TyThing] -> TcM a -> TcM a
378 addFamInsts tycons thing_inside
379 = tcExtendLocalFamInstEnv (map mkLocalFamInstTyThing tycons) thing_inside
381 mkLocalFamInstTyThing (ATyCon tycon) = mkLocalFamInst tycon
382 mkLocalFamInstTyThing tything = pprPanic "TcInstDcls.addFamInsts"
387 tcLocalInstDecl1 :: LInstDecl Name
388 -> TcM (InstInfo Name, [TyThing])
389 -- A source-file instance declaration
390 -- Type-check all the stuff before the "where"
392 -- We check for respectable instance type, and context
393 tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats))
395 addErrCtxt (instDeclCtxt1 poly_ty) $
397 do { is_boot <- tcIsHsBoot
398 ; checkTc (not is_boot || (isEmptyLHsBinds binds && null uprags))
401 ; (tyvars, theta, tau) <- tcHsInstHead poly_ty
403 -- Now, check the validity of the instance.
404 ; (clas, inst_tys) <- checkValidInstance poly_ty tyvars theta tau
406 -- Next, process any associated types.
407 ; idx_tycons <- recoverM (return []) $
408 do { idx_tycons <- checkNoErrs $
409 mapAndRecoverM (tcFamInstDecl NotTopLevel) ats
410 ; checkValidAndMissingATs clas (tyvars, inst_tys)
412 ; return idx_tycons }
414 -- Finally, construct the Core representation of the instance.
415 -- (This no longer includes the associated types.)
416 ; dfun_name <- newDFunName clas inst_tys (getLoc poly_ty)
417 -- Dfun location is that of instance *header*
418 ; overlap_flag <- getOverlapFlag
419 ; let (eq_theta,dict_theta) = partition isEqPred theta
420 theta' = eq_theta ++ dict_theta
421 dfun = mkDictFunId dfun_name tyvars theta' clas inst_tys
422 ispec = mkLocalInstance dfun overlap_flag
424 ; return (InstInfo { iSpec = ispec,
425 iBinds = VanillaInst binds uprags False },
429 -- We pass in the source form and the type checked form of the ATs. We
430 -- really need the source form only to be able to produce more informative
432 checkValidAndMissingATs :: Class
433 -> ([TyVar], [TcType]) -- instance types
434 -> [(LTyClDecl Name, -- source form of AT
435 TyThing)] -- Core form of AT
437 checkValidAndMissingATs clas inst_tys ats
438 = do { -- Issue a warning for each class AT that is not defined in this
440 ; let class_ats = map tyConName (classATs clas)
441 defined_ats = listToNameSet . map (tcdName.unLoc.fst) $ ats
442 omitted = filterOut (`elemNameSet` defined_ats) class_ats
443 ; warn <- doptM Opt_WarnMissingMethods
444 ; mapM_ (warnTc warn . omittedATWarn) omitted
446 -- Ensure that all AT indexes that correspond to class parameters
447 -- coincide with the types in the instance head. All remaining
448 -- AT arguments must be variables. Also raise an error for any
449 -- type instances that are not associated with this class.
450 ; mapM_ (checkIndexes clas inst_tys) ats
453 checkIndexes clas inst_tys (hsAT, ATyCon tycon)
454 -- !!!TODO: check that this does the Right Thing for indexed synonyms, too!
455 = checkIndexes' clas inst_tys hsAT
457 snd . fromJust . tyConFamInst_maybe $ tycon)
458 checkIndexes _ _ _ = panic "checkIndexes"
460 checkIndexes' clas (instTvs, instTys) hsAT (atTvs, atTys)
461 = let atName = tcdName . unLoc $ hsAT
463 setSrcSpan (getLoc hsAT) $
464 addErrCtxt (atInstCtxt atName) $
465 case find ((atName ==) . tyConName) (classATs clas) of
466 Nothing -> addErrTc $ badATErr clas atName -- not in this class
468 -- The following is tricky! We need to deal with three
469 -- complications: (1) The AT possibly only uses a subset of
470 -- the class parameters as indexes and those it uses may be in
471 -- a different order; (2) the AT may have extra arguments,
472 -- which must be type variables; and (3) variables in AT and
473 -- instance head will be different `Name's even if their
474 -- source lexemes are identical.
476 -- e.g. class C a b c where
477 -- data D b a :: * -> * -- NB (1) b a, omits c
478 -- instance C [x] Bool Char where
479 -- data D Bool [x] v = MkD x [v] -- NB (2) v
480 -- -- NB (3) the x in 'instance C...' have differnt
481 -- -- Names to x's in 'data D...'
483 -- Re (1), `poss' contains a permutation vector to extract the
484 -- class parameters in the right order.
486 -- Re (2), we wrap the (permuted) class parameters in a Maybe
487 -- type and use Nothing for any extra AT arguments. (First
488 -- equation of `checkIndex' below.)
490 -- Re (3), we replace any type variable in the AT parameters
491 -- that has the same source lexeme as some variable in the
492 -- instance types with the instance type variable sharing its
496 -- For *associated* type families, gives the position
497 -- of that 'TyVar' in the class argument list (0-indexed)
498 -- e.g. class C a b c where { type F c a :: *->* }
499 -- Then we get Just [2,0]
500 poss = catMaybes [ tv `elemIndex` classTyVars clas
501 | tv <- tyConTyVars atycon]
502 -- We will get Nothings for the "extra" type
503 -- variables in an associated data type
504 -- e.g. class C a where { data D a :: *->* }
505 -- here D gets arity 2 and has two tyvars
507 relevantInstTys = map (instTys !!) poss
508 instArgs = map Just relevantInstTys ++
509 repeat Nothing -- extra arguments
510 renaming = substSameTyVar atTvs instTvs
512 zipWithM_ checkIndex (substTys renaming atTys) instArgs
514 checkIndex ty Nothing
515 | isTyVarTy ty = return ()
516 | otherwise = addErrTc $ mustBeVarArgErr ty
517 checkIndex ty (Just instTy)
518 | ty `tcEqType` instTy = return ()
519 | otherwise = addErrTc $ wrongATArgErr ty instTy
521 listToNameSet = addListToNameSet emptyNameSet
523 substSameTyVar [] _ = emptyTvSubst
524 substSameTyVar (tv:tvs) replacingTvs =
525 let replacement = case find (tv `sameLexeme`) replacingTvs of
526 Nothing -> mkTyVarTy tv
527 Just rtv -> mkTyVarTy rtv
529 tv1 `sameLexeme` tv2 =
530 nameOccName (tyVarName tv1) == nameOccName (tyVarName tv2)
532 extendTvSubst (substSameTyVar tvs replacingTvs) tv replacement
536 %************************************************************************
538 Type-checking instance declarations, pass 2
540 %************************************************************************
543 tcInstDecls2 :: [LTyClDecl Name] -> [InstInfo Name]
545 -- (a) From each class declaration,
546 -- generate any default-method bindings
547 -- (b) From each instance decl
548 -- generate the dfun binding
550 tcInstDecls2 tycl_decls inst_decls
551 = do { -- (a) Default methods from class decls
552 let class_decls = filter (isClassDecl . unLoc) tycl_decls
553 ; dm_binds_s <- mapM tcClassDecl2 class_decls
554 ; let dm_binds = unionManyBags dm_binds_s
556 -- (b) instance declarations
557 ; let dm_ids = collectHsBindsBinders dm_binds
558 -- Add the default method Ids (again)
559 -- See Note [Default methods and instances]
560 ; inst_binds_s <- tcExtendIdEnv dm_ids $
561 mapM tcInstDecl2 inst_decls
564 ; return (dm_binds `unionBags` unionManyBags inst_binds_s) }
566 tcInstDecl2 :: InstInfo Name -> TcM (LHsBinds Id)
567 tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
568 = recoverM (return emptyLHsBinds) $
570 addErrCtxt (instDeclCtxt2 (idType dfun_id)) $
571 tc_inst_decl2 dfun_id ibinds
573 dfun_id = instanceDFunId ispec
574 loc = getSrcSpan dfun_id
577 See Note [Default methods and instances]
578 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
579 The default method Ids are already in the type environment (see Note
580 [Default method Ids and Template Haskell] in TcTyClsDcls), BUT they
581 don't have their InlinePragmas yet. Usually that would not matter,
582 because the simplifier propagates information from binding site to
583 use. But, unusually, when compiling instance decls we *copy* the
584 INLINE pragma from the default method to the method for that
585 particular operation (see Note [INLINE and default methods] below).
587 So right here in tcInstDecl2 we must re-extend the type envt with
588 the default method Ids replete with their INLINE pragmas. Urk.
591 tc_inst_decl2 :: Id -> InstBindings Name -> TcM (LHsBinds Id)
592 -- Returns a binding for the dfun
593 tc_inst_decl2 dfun_id inst_binds
594 = do { let rigid_info = InstSkol
595 inst_ty = idType dfun_id
596 loc = getSrcSpan dfun_id
598 -- Instantiate the instance decl with skolem constants
599 ; (inst_tyvars', dfun_theta', inst_head') <- tcSkolSigType rigid_info inst_ty
600 -- These inst_tyvars' scope over the 'where' part
601 -- Those tyvars are inside the dfun_id's type, which is a bit
602 -- bizarre, but OK so long as you realise it!
604 (clas, inst_tys') = tcSplitDFunHead inst_head'
605 (class_tyvars, sc_theta, sc_sels, op_items) = classBigSig clas
607 -- Instantiate the super-class context with inst_tys
608 sc_theta' = substTheta (zipOpenTvSubst class_tyvars inst_tys') sc_theta
610 -- Create dictionary Ids from the specified instance contexts.
611 ; dfun_ev_vars <- newEvVars dfun_theta'
612 ; self_dict <- newSelfDict clas inst_tys'
613 -- Default-method Ids may be mentioned in synthesised RHSs,
614 -- but they'll already be in the environment.
616 -- Cook up a binding for "self = df d1 .. dn",
617 -- to use in each method binding
618 -- Why? See Note [Subtle interaction of recursion and overlap]
619 ; let self_ev_bind = EvBind self_dict $
620 EvDFunApp dfun_id (mkTyVarTys inst_tyvars') dfun_ev_vars
622 -- Deal with 'SPECIALISE instance' pragmas
623 -- See Note [SPECIALISE instance pragmas]
624 ; spec_info <- tcSpecInstPrags dfun_id inst_binds
626 -- Typecheck the methods
627 ; (meth_ids, meth_binds)
628 <- tcExtendTyVarEnv inst_tyvars' $
629 tcInstanceMethods dfun_id clas inst_tyvars' dfun_ev_vars
630 inst_tys' self_ev_bind spec_info
633 -- Figure out bindings for the superclass context
634 ; let tc_sc = tcSuperClass inst_tyvars' dfun_ev_vars self_ev_bind
635 (sc_eqs, sc_dicts) = splitAt (classSCNEqs clas) sc_theta'
636 ; (sc_dict_ids, sc_binds) <- ASSERT( equalLength sc_sels sc_dicts )
637 ASSERT( all isEqPred sc_eqs )
638 mapAndUnzipM tc_sc (sc_sels `zip` sc_dicts)
641 ; (_eq_sc_binds, sc_eq_vars) <- checkConstraints InstSkol emptyVarSet
642 inst_tyvars' dfun_ev_vars $
643 emitWanteds ScOrigin sc_eqs
645 -- Create the result bindings
646 ; let dict_constr = classDataCon clas
647 dict_bind = mkVarBind self_dict dict_rhs
648 dict_rhs = foldl mk_app inst_constr dict_and_meth_ids
649 dict_and_meth_ids = sc_dict_ids ++ meth_ids
650 inst_constr = L loc $ wrapId (mkWpEvVarApps sc_eq_vars
651 <.> mkWpTyApps inst_tys')
652 (dataConWrapId dict_constr)
653 -- We don't produce a binding for the dict_constr; instead we
654 -- rely on the simplifier to unfold this saturated application
655 -- We do this rather than generate an HsCon directly, because
656 -- it means that the special cases (e.g. dictionary with only one
657 -- member) are dealt with by the common MkId.mkDataConWrapId code rather
658 -- than needing to be repeated here.
660 mk_app :: LHsExpr Id -> Id -> LHsExpr Id
661 mk_app fun arg_id = L loc (HsApp fun (L loc (wrapId arg_wrapper arg_id)))
662 arg_wrapper = mkWpEvVarApps dfun_ev_vars <.> mkWpTyApps (mkTyVarTys inst_tyvars')
664 -- Do not inline the dfun; instead give it a magic DFunFunfolding
665 -- See Note [ClassOp/DFun selection]
666 -- See also note [Single-method classes]
667 dfun_id_w_fun = dfun_id
668 `setIdUnfolding` mkDFunUnfolding inst_ty (map Var dict_and_meth_ids)
669 -- Not right for equality superclasses
670 `setInlinePragma` dfunInlinePragma
672 (spec_inst_prags, _) = spec_info
673 main_bind = AbsBinds { abs_tvs = inst_tyvars'
674 , abs_ev_vars = dfun_ev_vars
675 , abs_exports = [(inst_tyvars', dfun_id_w_fun, self_dict,
676 SpecPrags spec_inst_prags)]
677 , abs_ev_binds = emptyTcEvBinds
678 , abs_binds = unitBag dict_bind }
680 ; return (unitBag (L loc main_bind) `unionBags`
681 listToBag meth_binds `unionBags`
685 ------------------------------
686 tcSpecInstPrags :: DFunId -> InstBindings Name
687 -> TcM ([Located TcSpecPrag], PragFun)
688 tcSpecInstPrags _ (NewTypeDerived {})
689 = return ([], \_ -> [])
690 tcSpecInstPrags dfun_id (VanillaInst binds uprags _)
691 = do { spec_inst_prags <- mapM (wrapLocM (tcSpecInst dfun_id)) $
692 filter isSpecInstLSig uprags
693 -- The filter removes the pragmas for methods
694 ; return (spec_inst_prags, mkPragFun uprags binds) }
696 ------------------------------
697 tcSuperClass :: [TyVar] -> [EvVar]
699 -> (Id, PredType) -> TcM (Id, LHsBind Id)
700 -- Build a top level decl like
701 -- sc_op = /\a \d. let this = ... in
704 -- The "this" part is just-in-case (discarded if not used)
705 -- See Note [Recursive superclasses]
706 tcSuperClass tyvars dicts
707 self_ev_bind@(EvBind self_dict _)
709 = do { (ev_binds, wanted, sc_dict)
710 <- newImplication InstSkol emptyVarSet tyvars dicts $
711 emitWanted ScOrigin sc_pred
713 ; simplifySuperClass self_dict wanted
714 -- We include self_dict in the 'givens'; the simplifier
715 -- is clever enough to stop sc_pred geting bound by just
716 -- selecting from self_dict!!
719 ; let sc_op_ty = mkForAllTys tyvars $ mkPiTypes dicts (varType sc_dict)
720 sc_op_name = mkDerivedInternalName mkClassOpAuxOcc uniq
722 sc_op_id = mkLocalId sc_op_name sc_op_ty
723 sc_op_bind = VarBind { var_id = sc_op_id, var_inline = False
724 , var_rhs = L noSrcSpan $ wrapId sc_wrapper sc_dict }
725 sc_wrapper = mkWpTyLams tyvars
727 <.> mkWpLet (EvBinds (unitBag self_ev_bind))
730 ; return (sc_op_id, noLoc sc_op_bind) }
733 Note [Recursive superclasses]
734 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
735 See Trac #1470 for why we would *like* to add "self_dict" to the
736 available instances here. But we can't do so because then the superclases
737 get satisfied by selection from self_dict, and that leads to an immediate
738 loop. What we need is to add self_dict to Avails without adding its
739 superclasses, and we currently have no way to do that.
741 Note [SPECIALISE instance pragmas]
742 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
745 instance (Ix a, Ix b) => Ix (a,b) where
746 {-# SPECIALISE instance Ix (Int,Int) #-}
749 We do *not* want to make a specialised version of the dictionary
750 function. Rather, we want specialised versions of each method.
751 Thus we should generate something like this:
753 $dfIx :: (Ix a, Ix x) => Ix (a,b)
754 {- DFUN [$crange, ...] -}
755 $dfIx da db = Ix ($crange da db) (...other methods...)
757 $dfIxPair :: (Ix a, Ix x) => Ix (a,b)
758 {- DFUN [$crangePair, ...] -}
759 $dfIxPair = Ix ($crangePair da db) (...other methods...)
761 $crange :: (Ix a, Ix b) -> ((a,b),(a,b)) -> [(a,b)]
762 {-# SPECIALISE $crange :: ((Int,Int),(Int,Int)) -> [(Int,Int)] #-}
763 $crange da db = <blah>
765 {-# RULE range ($dfIx da db) = $crange da db #-}
769 * The RULE is unaffected by the specialisation. We don't want to
770 specialise $dfIx, because then it would need a specialised RULE
771 which is a pain. The single RULE works fine at all specialisations.
772 See Note [How instance declarations are translated] above
774 * Instead, we want to specialise the *method*, $crange
776 In practice, rather than faking up a SPECIALISE pragama for each
777 method (which is painful, since we'd have to figure out its
778 specialised type), we call tcSpecPrag *as if* were going to specialise
779 $dfIx -- you can see that in the call to tcSpecInst. That generates a
780 SpecPrag which, as it turns out, can be used unchanged for each method.
781 The "it turns out" bit is delicate, but it works fine!
784 tcSpecInst :: Id -> Sig Name -> TcM TcSpecPrag
785 tcSpecInst dfun_id prag@(SpecInstSig hs_ty)
786 = addErrCtxt (spec_ctxt prag) $
787 do { let name = idName dfun_id
788 ; (tyvars, theta, tau) <- tcHsInstHead hs_ty
789 ; let spec_ty = mkSigmaTy tyvars theta tau
790 ; co_fn <- tcSubType (SpecPragOrigin name) (SigSkol SpecInstCtxt)
791 (idType dfun_id) spec_ty
792 ; return (SpecPrag dfun_id co_fn defaultInlinePragma) }
794 spec_ctxt prag = hang (ptext (sLit "In the SPECIALISE pragma")) 2 (ppr prag)
796 tcSpecInst _ _ = panic "tcSpecInst"
799 %************************************************************************
801 Type-checking an instance method
803 %************************************************************************
806 - Make the method bindings, as a [(NonRec, HsBinds)], one per method
807 - Remembering to use fresh Name (the instance method Name) as the binder
808 - Bring the instance method Ids into scope, for the benefit of tcInstSig
809 - Use sig_fn mapping instance method Name -> instance tyvars
811 - Use tcValBinds to do the checking
814 tcInstanceMethods :: DFunId -> Class -> [TcTyVar]
817 -> EvBind -- "This" and its binding
818 -> ([Located TcSpecPrag], PragFun)
821 -> TcM ([Id], [LHsBind Id])
822 -- The returned inst_meth_ids all have types starting
823 -- forall tvs. theta => ...
824 tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
825 self_dict_ev (spec_inst_prags, prag_fn)
826 op_items (VanillaInst binds _ standalone_deriv)
827 = mapAndUnzipM tc_item op_items
829 ----------------------
830 tc_item :: (Id, DefMeth) -> TcM (Id, LHsBind Id)
831 tc_item (sel_id, dm_info)
832 = case findMethodBind (idName sel_id) binds of
833 Just user_bind -> tc_body sel_id standalone_deriv user_bind
834 Nothing -> tc_default sel_id dm_info
836 ----------------------
837 tc_body :: Id -> Bool -> LHsBind Name -> TcM (TcId, LHsBind Id)
838 tc_body sel_id generated_code rn_bind
839 = add_meth_ctxt sel_id generated_code rn_bind $
840 do { (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars
842 ; let prags = prag_fn (idName sel_id)
843 ; meth_id1 <- addInlinePrags meth_id prags
844 ; spec_prags <- tcSpecPrags meth_id1 prags
845 ; bind <- tcInstanceMethodBody InstSkol
846 tyvars dfun_ev_vars mb_dict_ev
847 meth_id1 local_meth_id meth_sig_fn
848 (mk_meth_spec_prags meth_id1 spec_prags)
850 ; return (meth_id1, bind) }
852 ----------------------
853 tc_default :: Id -> DefMeth -> TcM (TcId, LHsBind Id)
854 tc_default sel_id GenDefMeth -- Derivable type classes stuff
855 = do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id
856 ; tc_body sel_id False {- Not generated code? -} meth_bind }
858 tc_default sel_id NoDefMeth -- No default method at all
859 = do { warnMissingMethod sel_id
860 ; (meth_id, _) <- mkMethIds clas tyvars dfun_ev_vars
862 ; return (meth_id, mkVarBind meth_id $
863 mkLHsWrap lam_wrapper error_rhs) }
865 error_rhs = L loc $ HsApp error_fun error_msg
866 error_fun = L loc $ wrapId (WpTyApp meth_tau) nO_METHOD_BINDING_ERROR_ID
867 error_msg = L loc (HsLit (HsStringPrim (mkFastString error_string)))
868 meth_tau = funResultTy (applyTys (idType sel_id) inst_tys)
869 error_string = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
870 lam_wrapper = mkWpTyLams tyvars <.> mkWpLams dfun_ev_vars
872 tc_default sel_id (DefMeth dm_name) -- A polymorphic default method
873 = do { -- Build the typechecked version directly,
874 -- without calling typecheck_method;
875 -- see Note [Default methods in instances]
876 -- Generate /\as.\ds. let this = df as ds
877 -- in $dm inst_tys this
878 -- The 'let' is necessary only because HsSyn doesn't allow
879 -- you to apply a function to a dictionary *expression*.
881 ; (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars
883 ; dm_id <- tcLookupId dm_name
884 ; let dm_inline_prag = idInlinePragma dm_id
885 EvBind self_dict _ = self_dict_ev
886 rhs = HsWrap (mkWpEvVarApps [self_dict] <.> mkWpTyApps inst_tys) $
889 meth_bind = L loc $ VarBind { var_id = local_meth_id
890 , var_rhs = L loc rhs
891 , var_inline = False }
892 meth_id1 = meth_id `setInlinePragma` dm_inline_prag
893 -- Copy the inline pragma (if any) from the default
894 -- method to this version. Note [INLINE and default methods]
896 bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars
897 , abs_exports = [( tyvars, meth_id1, local_meth_id
898 , mk_meth_spec_prags meth_id1 [])]
899 , abs_ev_binds = EvBinds (unitBag self_dict_ev)
900 , abs_binds = unitBag meth_bind }
901 -- Default methods in an instance declaration can't have their own
902 -- INLINE or SPECIALISE pragmas. It'd be possible to allow them, but
903 -- currently they are rejected with
904 -- "INLINE pragma lacks an accompanying binding"
906 ; return (meth_id1, L loc bind) }
908 ----------------------
909 mk_meth_spec_prags :: Id -> [LTcSpecPrag] -> TcSpecPrags
910 -- Adapt the SPECIALISE pragmas to work for this method Id
911 -- There are two sources:
912 -- * spec_inst_prags: {-# SPECIALISE instance :: <blah> #-}
913 -- These ones have the dfun inside, but [perhaps surprisingly]
914 -- the correct wrapper
915 -- * spec_prags_for_me: {-# SPECIALISE op :: <blah> #-}
916 mk_meth_spec_prags meth_id spec_prags_for_me
917 = SpecPrags (spec_prags_for_me ++
918 [ L loc (SpecPrag meth_id wrap inl)
919 | L loc (SpecPrag _ wrap inl) <- spec_inst_prags])
921 loc = getSrcSpan dfun_id
922 meth_sig_fn _ = Just ([],loc) -- The 'Just' says "yes, there's a type sig"
923 -- But there are no scoped type variables from local_method_id
924 -- Only the ones from the instance decl itself, which are already
925 -- in scope. Example:
926 -- class C a where { op :: forall b. Eq b => ... }
927 -- instance C [c] where { op = <rhs> }
928 -- In <rhs>, 'c' is scope but 'b' is not!
930 mb_dict_ev = if null tyvars then Nothing else Just self_dict_ev
931 -- Only need the self_dict stuff if there are type
932 -- variables involved; otherwise overlap is not possible
933 -- See Note [Subtle interaction of recursion and overlap]
936 -- For instance decls that come from standalone deriving clauses
937 -- we want to print out the full source code if there's an error
938 -- because otherwise the user won't see the code at all
939 add_meth_ctxt sel_id generated_code rn_bind thing
940 | generated_code = addLandmarkErrCtxt (derivBindCtxt sel_id clas inst_tys rn_bind) thing
944 tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
945 _ _ op_items (NewTypeDerived coi _)
948 -- class Show b => Foo a b where
950 -- newtype N a = MkN (Tree [a])
951 -- deriving instance (Show p, Foo Int p) => Foo Int (N p)
952 -- -- NB: standalone deriving clause means
953 -- -- that the contex is user-specified
954 -- Hence op :: forall a b. Foo a b => a -> b -> b
956 -- We're going to make an instance like
957 -- instance (Show p, Foo Int p) => Foo Int (N p)
960 -- $copT :: forall p. (Show p, Foo Int p) => Int -> N p -> N p
961 -- $copT p (d1:Show p) (d2:Foo Int p)
962 -- = op Int (Tree [p]) rep_d |> op_co
964 -- rep_d :: Foo Int (Tree [p]) = ...d1...d2...
965 -- op_co :: (Int -> Tree [p] -> Tree [p]) ~ (Int -> T p -> T p)
966 -- We get op_co by substituting [Int/a] and [co/b] in type for op
967 -- where co : [p] ~ T p
969 -- Notice that the dictionary bindings "..d1..d2.." must be generated
970 -- by the constraint solver, since the <context> may be
973 = do { rep_d_stuff <- checkConstraints InstSkol emptyVarSet tyvars dfun_ev_vars $
974 emitWanted ScOrigin rep_pred
976 ; mapAndUnzipM (tc_item rep_d_stuff) op_items }
978 loc = getSrcSpan dfun_id
980 inst_tvs = fst (tcSplitForAllTys (idType dfun_id))
981 Just (init_inst_tys, _) = snocView inst_tys
982 rep_ty = fst (coercionKind co) -- [p]
983 rep_pred = mkClassPred clas (init_inst_tys ++ [rep_ty])
986 co = substTyWith inst_tvs (mkTyVarTys tyvars) $
987 case coi of { IdCo ty -> ty ;
988 ACo co -> mkSymCoercion co }
991 tc_item :: (TcEvBinds, EvVar) -> (Id, DefMeth) -> TcM (TcId, LHsBind TcId)
992 tc_item (rep_ev_binds, rep_d) (sel_id, _)
993 = do { (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars
996 ; let meth_rhs = wrapId (mk_op_wrapper sel_id rep_d) sel_id
997 meth_bind = VarBind { var_id = local_meth_id
998 , var_rhs = L loc meth_rhs
999 , var_inline = False }
1001 bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars
1002 , abs_exports = [(tyvars, meth_id,
1003 local_meth_id, noSpecPrags)]
1004 , abs_ev_binds = rep_ev_binds
1005 , abs_binds = unitBag $ L loc meth_bind }
1007 ; return (meth_id, L loc bind) }
1010 mk_op_wrapper :: Id -> EvVar -> HsWrapper
1011 mk_op_wrapper sel_id rep_d
1012 = WpCast (substTyWith sel_tvs (init_inst_tys ++ [co]) local_meth_ty)
1013 <.> WpEvApp (EvId rep_d)
1014 <.> mkWpTyApps (init_inst_tys ++ [rep_ty])
1016 (sel_tvs, sel_rho) = tcSplitForAllTys (idType sel_id)
1017 (_, local_meth_ty) = tcSplitPredFunTy_maybe sel_rho
1018 `orElse` pprPanic "tcInstanceMethods" (ppr sel_id)
1020 ----------------------
1021 mkMethIds :: Class -> [TcTyVar] -> [EvVar] -> [TcType] -> Id -> TcM (TcId, TcId)
1022 mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id
1023 = do { uniq <- newUnique
1024 ; let meth_name = mkDerivedInternalName mkClassOpAuxOcc uniq sel_name
1025 ; local_meth_name <- newLocalName sel_name
1026 -- Base the local_meth_name on the selector name, becuase
1027 -- type errors from tcInstanceMethodBody come from here
1029 ; let meth_id = mkLocalId meth_name meth_ty
1030 local_meth_id = mkLocalId local_meth_name local_meth_ty
1031 ; return (meth_id, local_meth_id) }
1033 local_meth_ty = instantiateMethod clas sel_id inst_tys
1034 meth_ty = mkForAllTys tyvars $ mkPiTypes dfun_ev_vars local_meth_ty
1035 sel_name = idName sel_id
1037 ----------------------
1038 wrapId :: HsWrapper -> id -> HsExpr id
1039 wrapId wrapper id = mkHsWrap wrapper (HsVar id)
1041 derivBindCtxt :: Id -> Class -> [Type ] -> LHsBind Name -> SDoc
1042 derivBindCtxt sel_id clas tys _bind
1043 = vcat [ ptext (sLit "When typechecking the code for ") <+> quotes (ppr sel_id)
1044 , nest 2 (ptext (sLit "in a standalone derived instance for")
1045 <+> quotes (pprClassPred clas tys) <> colon)
1046 , nest 2 $ ptext (sLit "To see the code I am typechecking, use -ddump-deriv") ]
1049 -- , nest 2 $ pprSetDepth AllTheWay $ ppr bind ]
1051 warnMissingMethod :: Id -> TcM ()
1052 warnMissingMethod sel_id
1053 = do { warn <- doptM Opt_WarnMissingMethods
1054 ; warnTc (warn -- Warn only if -fwarn-missing-methods
1055 && not (startsWithUnderscore (getOccName sel_id)))
1056 -- Don't warn about _foo methods
1057 (ptext (sLit "No explicit method nor default method for")
1058 <+> quotes (ppr sel_id)) }
1061 Note [Export helper functions]
1062 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1063 We arrange to export the "helper functions" of an instance declaration,
1064 so that they are not subject to preInlineUnconditionally, even if their
1065 RHS is trivial. Reason: they are mentioned in the DFunUnfolding of
1066 the dict fun as Ids, not as CoreExprs, so we can't substitute a
1067 non-variable for them.
1069 We could change this by making DFunUnfoldings have CoreExprs, but it
1070 seems a bit simpler this way.
1072 Note [Default methods in instances]
1073 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1080 instance Baz Int Int
1082 From the class decl we get
1084 $dmfoo :: forall v x. Baz v x => x -> x
1087 Notice that the type is ambiguous. That's fine, though. The instance
1090 $dBazIntInt = MkBaz fooIntInt
1091 fooIntInt = $dmfoo Int Int $dBazIntInt
1093 BUT this does mean we must generate the dictionary translation of
1094 fooIntInt directly, rather than generating source-code and
1095 type-checking it. That was the bug in Trac #1061. In any case it's
1096 less work to generate the translated version!
1098 Note [INLINE and default methods]
1099 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1100 Default methods need special case. They are supposed to behave rather like
1101 macros. For exmample
1104 op1, op2 :: Bool -> a -> a
1107 op1 b x = op2 (not b) x
1109 instance Foo Int where
1110 -- op1 via default method
1113 The instance declaration should behave
1115 just as if 'op1' had been defined with the
1116 code, and INLINE pragma, from its original
1119 That is, just as if you'd written
1121 instance Foo Int where
1125 op1 b x = op2 (not b) x
1127 So for the above example we generate:
1130 {-# INLINE $dmop1 #-}
1131 -- $dmop1 has an InlineCompulsory unfolding
1132 $dmop1 d b x = op2 d (not b) x
1134 $fFooInt = MkD $cop1 $cop2
1136 {-# INLINE $cop1 #-}
1137 $cop1 = $dmop1 $fFooInt
1143 * We *copy* any INLINE pragma from the default method $dmop1 to the
1144 instance $cop1. Otherwise we'll just inline the former in the
1145 latter and stop, which isn't what the user expected
1147 * Regardless of its pragma, we give the default method an
1148 unfolding with an InlineCompulsory source. That means
1149 that it'll be inlined at every use site, notably in
1150 each instance declaration, such as $cop1. This inlining
1151 must happen even though
1152 a) $dmop1 is not saturated in $cop1
1153 b) $cop1 itself has an INLINE pragma
1155 It's vital that $dmop1 *is* inlined in this way, to allow the mutual
1156 recursion between $fooInt and $cop1 to be broken
1158 * To communicate the need for an InlineCompulsory to the desugarer
1159 (which makes the Unfoldings), we use the IsDefaultMethod constructor
1163 %************************************************************************
1165 \subsection{Error messages}
1167 %************************************************************************
1170 instDeclCtxt1 :: LHsType Name -> SDoc
1171 instDeclCtxt1 hs_inst_ty
1172 = inst_decl_ctxt (case unLoc hs_inst_ty of
1173 HsForAllTy _ _ _ (L _ (HsPredTy pred)) -> ppr pred
1174 HsPredTy pred -> ppr pred
1175 _ -> ppr hs_inst_ty) -- Don't expect this
1176 instDeclCtxt2 :: Type -> SDoc
1177 instDeclCtxt2 dfun_ty
1178 = inst_decl_ctxt (ppr (mkClassPred cls tys))
1180 (_,cls,tys) = tcSplitDFunTy dfun_ty
1182 inst_decl_ctxt :: SDoc -> SDoc
1183 inst_decl_ctxt doc = ptext (sLit "In the instance declaration for") <+> quotes doc
1185 atInstCtxt :: Name -> SDoc
1186 atInstCtxt name = ptext (sLit "In the associated type instance for") <+>
1189 mustBeVarArgErr :: Type -> SDoc
1190 mustBeVarArgErr ty =
1191 sep [ ptext (sLit "Arguments that do not correspond to a class parameter") <+>
1192 ptext (sLit "must be variables")
1193 , ptext (sLit "Instead of a variable, found") <+> ppr ty
1196 wrongATArgErr :: Type -> Type -> SDoc
1197 wrongATArgErr ty instTy =
1198 sep [ ptext (sLit "Type indexes must match class instance head")
1199 , ptext (sLit "Found") <+> quotes (ppr ty)
1200 <+> ptext (sLit "but expected") <+> quotes (ppr instTy)