2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
6 TcInstDecls: Typechecking instance declarations
10 -- The above warning supression flag is a temporary kludge.
11 -- While working on this module you are encouraged to remove it and fix
12 -- any warnings in the module. See
13 -- http://hackage.haskell.org/trac/ghc/wiki/CodingStyle#Warnings
16 module TcInstDcls ( tcInstDecls1, tcInstDecls2 ) where
18 #include "HsVersions.h"
57 import Control.Monad hiding (zipWithM_, mapAndUnzipM)
61 Typechecking instance declarations is done in two passes. The first
62 pass, made by @tcInstDecls1@, collects information to be used in the
65 This pre-processed info includes the as-yet-unprocessed bindings
66 inside the instance declaration. These are type-checked in the second
67 pass, when the class-instance envs and GVE contain all the info from
68 all the instance and value decls. Indeed that's the reason we need
69 two passes over the instance decls.
71 Here is the overall algorithm.
72 Assume that we have an instance declaration
74 instance c => k (t tvs) where b
78 $LIE_c$ is the LIE for the context of class $c$
80 $betas_bar$ is the free variables in the class method type, excluding the
83 $LIE_cop$ is the LIE constraining a particular class method
85 $tau_cop$ is the tau type of a class method
87 $LIE_i$ is the LIE for the context of instance $i$
89 $X$ is the instance constructor tycon
91 $gammas_bar$ is the set of type variables of the instance
93 $LIE_iop$ is the LIE for a particular class method instance
95 $tau_iop$ is the tau type for this instance of a class method
97 $alpha$ is the class variable
99 $LIE_cop' = LIE_cop [X gammas_bar / alpha, fresh betas_bar]$
101 $tau_cop' = tau_cop [X gammas_bar / alpha, fresh betas_bar]$
104 ToDo: Update the list above with names actually in the code.
108 First, make the LIEs for the class and instance contexts, which means
109 instantiate $thetaC [X inst_tyvars / alpha ]$, yielding LIElistC' and LIEC',
110 and make LIElistI and LIEI.
112 Then process each method in turn.
114 order the instance methods according to the ordering of the class methods
116 express LIEC' in terms of LIEI, yielding $dbinds_super$ or an error
118 Create final dictionary function from bindings generated already
120 df = lambda inst_tyvars
127 in <op1,op2,...,opn,sd1,...,sdm>
129 Here, Bop1 \ldots Bopn bind the methods op1 \ldots opn,
130 and $dbinds_super$ bind the superclass dictionaries sd1 \ldots sdm.
134 %************************************************************************
136 \subsection{Extracting instance decls}
138 %************************************************************************
140 Gather up the instance declarations from their various sources
143 tcInstDecls1 -- Deal with both source-code and imported instance decls
144 :: [LTyClDecl Name] -- For deriving stuff
145 -> [LInstDecl Name] -- Source code instance decls
146 -> [LDerivDecl Name] -- Source code stand-alone deriving decls
147 -> TcM (TcGblEnv, -- The full inst env
148 [InstInfo], -- Source-code instance decls to process;
149 -- contains all dfuns for this module
150 HsValBinds Name) -- Supporting bindings for derived instances
152 tcInstDecls1 tycl_decls inst_decls deriv_decls
154 do { -- Stop if addInstInfos etc discovers any errors
155 -- (they recover, so that we get more than one error each
158 -- (1) Do class and family instance declarations
159 ; let { idxty_decls = filter (isFamInstDecl . unLoc) tycl_decls }
160 ; local_info_tycons <- mappM tcLocalInstDecl1 inst_decls
161 ; idx_tycons <- mappM tcIdxTyInstDeclTL idxty_decls
163 ; let { (local_infos,
164 at_tycons) = unzip local_info_tycons
165 ; local_info = concat local_infos
166 ; at_idx_tycon = concat at_tycons ++ catMaybes idx_tycons
167 ; clas_decls = filter (isClassDecl.unLoc) tycl_decls
168 ; implicit_things = concatMap implicitTyThings at_idx_tycon
171 -- (2) Add the tycons of indexed types and their implicit
172 -- tythings to the global environment
173 ; tcExtendGlobalEnv (at_idx_tycon ++ implicit_things) $ do {
175 -- (3) Instances from generic class declarations
176 ; generic_inst_info <- getGenericInstances clas_decls
178 -- Next, construct the instance environment so far, consisting
180 -- a) local instance decls
181 -- b) generic instances
182 -- c) local family instance decls
183 ; addInsts local_info $ do {
184 ; addInsts generic_inst_info $ do {
185 ; addFamInsts at_idx_tycon $ do {
187 -- (4) Compute instances from "deriving" clauses;
188 -- This stuff computes a context for the derived instance
189 -- decl, so it needs to know about all the instances possible
190 -- NB: class instance declarations can contain derivings as
191 -- part of associated data type declarations
192 ; (deriv_inst_info, deriv_binds) <- tcDeriving tycl_decls inst_decls
194 ; addInsts deriv_inst_info $ do {
196 ; gbl_env <- getGblEnv
198 generic_inst_info ++ deriv_inst_info ++ local_info,
202 -- Make sure that toplevel type instance are not for associated types.
203 -- !!!TODO: Need to perform this check for the TyThing of type functions,
205 tcIdxTyInstDeclTL ldecl@(L loc decl) =
206 do { tything <- tcFamInstDecl ldecl
208 when (isAssocFamily tything) $
209 addErr $ assocInClassErr (tcdName decl)
212 isAssocFamily (Just (ATyCon tycon)) =
213 case tyConFamInst_maybe tycon of
214 Nothing -> panic "isAssocFamily: no family?!?"
215 Just (fam, _) -> isTyConAssoc fam
216 isAssocFamily (Just _ ) = panic "isAssocFamily: no tycon?!?"
217 isAssocFamily Nothing = False
219 assocInClassErr name =
220 ptext SLIT("Associated type") <+> quotes (ppr name) <+>
221 ptext SLIT("must be inside a class instance")
223 addInsts :: [InstInfo] -> TcM a -> TcM a
224 addInsts infos thing_inside
225 = tcExtendLocalInstEnv (map iSpec infos) thing_inside
227 addFamInsts :: [TyThing] -> TcM a -> TcM a
228 addFamInsts tycons thing_inside
229 = tcExtendLocalFamInstEnv (map mkLocalFamInstTyThing tycons) thing_inside
231 mkLocalFamInstTyThing (ATyCon tycon) = mkLocalFamInst tycon
232 mkLocalFamInstTyThing tything = pprPanic "TcInstDcls.addFamInsts"
237 tcLocalInstDecl1 :: LInstDecl Name
238 -> TcM ([InstInfo], [TyThing]) -- [] if there was an error
239 -- A source-file instance declaration
240 -- Type-check all the stuff before the "where"
242 -- We check for respectable instance type, and context
243 tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags ats))
244 = -- Prime error recovery, set source location
245 recoverM (returnM ([], [])) $
247 addErrCtxt (instDeclCtxt1 poly_ty) $
249 do { is_boot <- tcIsHsBoot
250 ; checkTc (not is_boot || (isEmptyLHsBinds binds && null uprags))
253 ; (tyvars, theta, tau) <- tcHsInstHead poly_ty
255 -- Next, process any associated types.
256 ; idx_tycons <- mappM tcFamInstDecl ats
258 -- Now, check the validity of the instance.
259 ; (clas, inst_tys) <- checkValidInstHead tau
260 ; checkValidInstance tyvars theta clas inst_tys
261 ; checkValidAndMissingATs clas (tyvars, inst_tys)
264 -- Finally, construct the Core representation of the instance.
265 -- (This no longer includes the associated types.)
266 ; dfun_name <- newDFunName clas inst_tys loc
267 ; overlap_flag <- getOverlapFlag
268 ; let (eq_theta,dict_theta) = partition isEqPred theta
269 theta' = eq_theta ++ dict_theta
270 dfun = mkDictFunId dfun_name tyvars theta' clas inst_tys
271 ispec = mkLocalInstance dfun overlap_flag
273 ; return ([InstInfo { iSpec = ispec,
274 iBinds = VanillaInst binds uprags }],
275 catMaybes idx_tycons)
278 -- We pass in the source form and the type checked form of the ATs. We
279 -- really need the source form only to be able to produce more informative
281 checkValidAndMissingATs :: Class
282 -> ([TyVar], [TcType]) -- instance types
283 -> [(LTyClDecl Name, -- source form of AT
284 Maybe TyThing)] -- Core form of AT
286 checkValidAndMissingATs clas inst_tys ats
287 = do { -- Issue a warning for each class AT that is not defined in this
289 ; let class_ats = map tyConName (classATs clas)
290 defined_ats = listToNameSet . map (tcdName.unLoc.fst) $ ats
291 omitted = filterOut (`elemNameSet` defined_ats) class_ats
292 ; warn <- doptM Opt_WarnMissingMethods
293 ; mapM_ (warnTc warn . omittedATWarn) omitted
295 -- Ensure that all AT indexes that correspond to class parameters
296 -- coincide with the types in the instance head. All remaining
297 -- AT arguments must be variables. Also raise an error for any
298 -- type instances that are not associated with this class.
299 ; mapM_ (checkIndexes clas inst_tys) ats
302 checkIndexes _ _ (hsAT, Nothing) =
303 return () -- skip, we already had an error here
304 checkIndexes clas inst_tys (hsAT, Just (ATyCon tycon)) =
305 -- !!!TODO: check that this does the Right Thing for indexed synonyms, too!
306 checkIndexes' clas inst_tys hsAT
308 snd . fromJust . tyConFamInst_maybe $ tycon)
309 checkIndexes _ _ _ = panic "checkIndexes"
311 checkIndexes' clas (instTvs, instTys) hsAT (atTvs, atTys)
312 = let atName = tcdName . unLoc $ hsAT
314 setSrcSpan (getLoc hsAT) $
315 addErrCtxt (atInstCtxt atName) $
316 case find ((atName ==) . tyConName) (classATs clas) of
317 Nothing -> addErrTc $ badATErr clas atName -- not in this class
319 case assocTyConArgPoss_maybe atDecl of
320 Nothing -> panic "checkIndexes': AT has no args poss?!?"
323 -- The following is tricky! We need to deal with three
324 -- complications: (1) The AT possibly only uses a subset of
325 -- the class parameters as indexes and those it uses may be in
326 -- a different order; (2) the AT may have extra arguments,
327 -- which must be type variables; and (3) variables in AT and
328 -- instance head will be different `Name's even if their
329 -- source lexemes are identical.
331 -- Re (1), `poss' contains a permutation vector to extract the
332 -- class parameters in the right order.
334 -- Re (2), we wrap the (permuted) class parameters in a Maybe
335 -- type and use Nothing for any extra AT arguments. (First
336 -- equation of `checkIndex' below.)
338 -- Re (3), we replace any type variable in the AT parameters
339 -- that has the same source lexeme as some variable in the
340 -- instance types with the instance type variable sharing its
343 let relevantInstTys = map (instTys !!) poss
344 instArgs = map Just relevantInstTys ++
345 repeat Nothing -- extra arguments
346 renaming = substSameTyVar atTvs instTvs
348 zipWithM_ checkIndex (substTys renaming atTys) instArgs
350 checkIndex ty Nothing
351 | isTyVarTy ty = return ()
352 | otherwise = addErrTc $ mustBeVarArgErr ty
353 checkIndex ty (Just instTy)
354 | ty `tcEqType` instTy = return ()
355 | otherwise = addErrTc $ wrongATArgErr ty instTy
357 listToNameSet = addListToNameSet emptyNameSet
359 substSameTyVar [] _ = emptyTvSubst
360 substSameTyVar (tv:tvs) replacingTvs =
361 let replacement = case find (tv `sameLexeme`) replacingTvs of
362 Nothing -> mkTyVarTy tv
363 Just rtv -> mkTyVarTy rtv
365 tv1 `sameLexeme` tv2 =
366 nameOccName (tyVarName tv1) == nameOccName (tyVarName tv2)
368 extendTvSubst (substSameTyVar tvs replacingTvs) tv replacement
372 %************************************************************************
374 \subsection{Type-checking instance declarations, pass 2}
376 %************************************************************************
379 tcInstDecls2 :: [LTyClDecl Name] -> [InstInfo]
380 -> TcM (LHsBinds Id, TcLclEnv)
381 -- (a) From each class declaration,
382 -- generate any default-method bindings
383 -- (b) From each instance decl
384 -- generate the dfun binding
386 tcInstDecls2 tycl_decls inst_decls
387 = do { -- (a) Default methods from class decls
388 (dm_binds_s, dm_ids_s) <- mapAndUnzipM tcClassDecl2 $
389 filter (isClassDecl.unLoc) tycl_decls
390 ; tcExtendIdEnv (concat dm_ids_s) $ do
392 -- (b) instance declarations
393 ; inst_binds_s <- mappM tcInstDecl2 inst_decls
396 ; let binds = unionManyBags dm_binds_s `unionBags`
397 unionManyBags inst_binds_s
398 ; tcl_env <- getLclEnv -- Default method Ids in here
399 ; returnM (binds, tcl_env) }
402 ======= New documentation starts here (Sept 92) ==============
404 The main purpose of @tcInstDecl2@ is to return a @HsBinds@ which defines
405 the dictionary function for this instance declaration. For example
407 instance Foo a => Foo [a] where
411 might generate something like
413 dfun.Foo.List dFoo_a = let op1 x = ...
419 HOWEVER, if the instance decl has no context, then it returns a
420 bigger @HsBinds@ with declarations for each method. For example
422 instance Foo [a] where
428 dfun.Foo.List a = Dict [Foo.op1.List a, Foo.op2.List a]
429 const.Foo.op1.List a x = ...
430 const.Foo.op2.List a y = ...
432 This group may be mutually recursive, because (for example) there may
433 be no method supplied for op2 in which case we'll get
435 const.Foo.op2.List a = default.Foo.op2 (dfun.Foo.List a)
437 that is, the default method applied to the dictionary at this type.
439 What we actually produce in either case is:
441 AbsBinds [a] [dfun_theta_dicts]
442 [(dfun.Foo.List, d)] ++ (maybe) [(const.Foo.op1.List, op1), ...]
443 { d = (sd1,sd2, ..., op1, op2, ...)
448 The "maybe" says that we only ask AbsBinds to make global constant methods
449 if the dfun_theta is empty.
452 For an instance declaration, say,
454 instance (C1 a, C2 b) => C (T a b) where
457 where the {\em immediate} superclasses of C are D1, D2, we build a dictionary
458 function whose type is
460 (C1 a, C2 b, D1 (T a b), D2 (T a b)) => C (T a b)
462 Notice that we pass it the superclass dictionaries at the instance type; this
463 is the ``Mark Jones optimisation''. The stuff before the "=>" here
464 is the @dfun_theta@ below.
466 First comes the easy case of a non-local instance decl.
470 tcInstDecl2 :: InstInfo -> TcM (LHsBinds Id)
471 -- Returns a binding for the dfun
473 ------------------------
474 -- Derived newtype instances; surprisingly tricky!
476 -- In the case of a newtype, things are rather easy
477 -- class Show a => Foo a b where ...
478 -- newtype T a = MkT (Tree [a]) deriving( Foo Int )
479 -- The newtype gives an FC axiom looking like
480 -- axiom CoT a :: T a :=: Tree [a]
481 -- (see Note [Newtype coercions] in TyCon for this unusual form of axiom)
483 -- So all need is to generate a binding looking like:
484 -- dfunFooT :: forall a. (Foo Int (Tree [a], Show (T a)) => Foo Int (T a)
485 -- dfunFooT = /\a. \(ds:Show (T a)) (df:Foo (Tree [a])).
486 -- case df `cast` (Foo Int (sym (CoT a))) of
487 -- Foo _ op1 .. opn -> Foo ds op1 .. opn
489 -- If there are no superclasses, matters are simpler, because we don't need the case
490 -- see Note [Newtype deriving superclasses] in TcDeriv.lhs
492 tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = NewTypeDerived mb_preds })
493 = do { let dfun_id = instanceDFunId ispec
494 rigid_info = InstSkol
495 origin = SigOrigin rigid_info
496 inst_ty = idType dfun_id
497 ; (tvs, theta, inst_head_ty) <- tcSkolSigType rigid_info inst_ty
498 -- inst_head_ty is a PredType
500 ; inst_loc <- getInstLoc origin
501 ; (rep_dict_id : sc_dict_ids, wrap_fn, sc_binds)
502 <- make_wrapper inst_loc tvs theta mb_preds
503 -- Here, we are relying on the order of dictionary
504 -- arguments built by NewTypeDerived in TcDeriv;
505 -- namely, that the rep_dict_id comes first
507 ; let (cls, cls_inst_tys) = tcSplitDFunHead inst_head_ty
508 cls_tycon = classTyCon cls
509 the_coercion = make_coercion cls_tycon cls_inst_tys
510 coerced_rep_dict = mkHsWrap the_coercion (HsVar rep_dict_id)
512 ; body <- make_body cls_tycon cls_inst_tys sc_dict_ids coerced_rep_dict
514 ; return (sc_binds `snocBag` (noLoc $ VarBind dfun_id $ noLoc $ mkHsWrap wrap_fn body)) }
517 -----------------------
519 -- We distinguish two cases:
520 -- (a) there is no tyvar abstraction in the dfun, so all dicts are constant,
521 -- and the new dict can just be a constant
522 -- (mb_preds = Just preds)
523 -- (b) there are tyvars, so we must make a dict *fun*
524 -- (mb_preds = Nothing)
525 -- See the defn of NewTypeDerived for the meaning of mb_preds
526 make_wrapper inst_loc tvs theta (Just preds) -- Case (a)
527 = ASSERT( null tvs && null theta )
528 do { dicts <- newDictBndrs inst_loc preds
529 ; sc_binds <- addErrCtxt superClassCtxt $
530 tcSimplifySuperClasses inst_loc [] dicts
531 -- Use tcSimplifySuperClasses to avoid creating loops, for the
532 -- same reason as Note [SUPERCLASS-LOOP 1] in TcSimplify
533 ; return (map instToId dicts, idHsWrapper, sc_binds) }
535 make_wrapper inst_loc tvs theta Nothing -- Case (b)
536 = do { dicts <- newDictBndrs inst_loc theta
537 ; let dict_ids = map instToId dicts
538 ; return (dict_ids, mkWpTyLams tvs <.> mkWpLams dict_ids, emptyBag) }
540 -----------------------
542 -- The inst_head looks like (C s1 .. sm (T a1 .. ak))
543 -- But we want the coercion (C s1 .. sm (sym (CoT a1 .. ak)))
544 -- with kind (C s1 .. sm (T a1 .. ak) :=: C s1 .. sm <rep_ty>)
545 -- where rep_ty is the (eta-reduced) type rep of T
546 -- So we just replace T with CoT, and insert a 'sym'
547 -- NB: we know that k will be >= arity of CoT, because the latter fully eta-reduced
549 make_coercion cls_tycon cls_inst_tys
550 | Just (all_tys_but_last, last_ty) <- snocView cls_inst_tys
551 , (tycon, tc_args) <- tcSplitTyConApp last_ty -- Should not fail
552 , Just co_con <- newTyConCo_maybe tycon
553 , let co = mkSymCoercion (mkTyConApp co_con tc_args)
554 = WpCo (mkTyConApp cls_tycon (all_tys_but_last ++ [co]))
555 | otherwise -- The newtype is transparent; no need for a cast
558 -----------------------
560 -- Two cases; see Note [Newtype deriving superclasses] in TcDeriv.lhs
561 -- (a) no superclasses; then we can just use the coerced dict
562 -- (b) one or more superclasses; then new need to do the unpack/repack
564 make_body cls_tycon cls_inst_tys sc_dict_ids coerced_rep_dict
565 | null sc_dict_ids -- Case (a)
566 = return coerced_rep_dict
567 | otherwise -- Case (b)
568 = do { op_ids <- newSysLocalIds FSLIT("op") op_tys
569 ; dummy_sc_dict_ids <- newSysLocalIds FSLIT("sc") (map idType sc_dict_ids)
570 ; let the_pat = ConPatOut { pat_con = noLoc cls_data_con, pat_tvs = [],
571 pat_dicts = dummy_sc_dict_ids,
572 pat_binds = emptyLHsBinds,
573 pat_args = PrefixCon (map nlVarPat op_ids),
575 the_match = mkSimpleMatch [noLoc the_pat] the_rhs
576 the_rhs = mkHsConApp cls_data_con cls_inst_tys $
577 map HsVar (sc_dict_ids ++ op_ids)
579 -- Warning: this HsCase scrutinises a value with a PredTy, which is
580 -- never otherwise seen in Haskell source code. It'd be
581 -- nicer to generate Core directly!
582 ; return (HsCase (noLoc coerced_rep_dict) $
583 MatchGroup [the_match] (mkFunTy pat_ty pat_ty)) }
585 pat_ty = mkTyConApp cls_tycon cls_inst_tys
586 cls_data_con = head (tyConDataCons cls_tycon)
587 cls_arg_tys = dataConInstArgTys cls_data_con cls_inst_tys
588 op_tys = dropList sc_dict_ids cls_arg_tys
590 ------------------------
591 -- Ordinary instances
593 tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags })
595 dfun_id = instanceDFunId ispec
596 rigid_info = InstSkol
597 inst_ty = idType dfun_id
598 loc = srcLocSpan (getSrcLoc dfun_id)
600 -- Prime error recovery
601 recoverM (returnM emptyLHsBinds) $
603 addErrCtxt (instDeclCtxt2 (idType dfun_id)) $
605 -- Instantiate the instance decl with skolem constants
606 tcSkolSigType rigid_info inst_ty `thenM` \ (inst_tyvars', dfun_theta', inst_head') ->
607 -- These inst_tyvars' scope over the 'where' part
608 -- Those tyvars are inside the dfun_id's type, which is a bit
609 -- bizarre, but OK so long as you realise it!
611 (clas, inst_tys') = tcSplitDFunHead inst_head'
612 (class_tyvars, sc_theta, _, op_items) = classBigSig clas
614 -- Instantiate the super-class context with inst_tys
615 sc_theta' = substTheta (zipOpenTvSubst class_tyvars inst_tys') sc_theta
616 (eq_sc_theta',dict_sc_theta') = partition isEqPred sc_theta'
617 origin = SigOrigin rigid_info
618 (eq_dfun_theta',dict_dfun_theta') = partition isEqPred dfun_theta'
620 -- Create dictionary Ids from the specified instance contexts.
621 getInstLoc InstScOrigin `thenM` \ sc_loc ->
622 newDictBndrs sc_loc dict_sc_theta' `thenM` \ sc_dicts ->
623 getInstLoc origin `thenM` \ inst_loc ->
624 mkMetaCoVars eq_sc_theta' `thenM` \ sc_covars ->
625 mkEqInsts eq_sc_theta' (map mkWantedCo sc_covars) `thenM` \ wanted_sc_eqs ->
626 mkCoVars eq_dfun_theta' `thenM` \ dfun_covars ->
627 mkEqInsts eq_dfun_theta' (map mkGivenCo $ mkTyVarTys dfun_covars) `thenM` \ dfun_eqs ->
628 newDictBndrs inst_loc dict_dfun_theta' `thenM` \ dfun_dicts ->
629 newDictBndr inst_loc (mkClassPred clas inst_tys') `thenM` \ this_dict ->
630 -- Default-method Ids may be mentioned in synthesised RHSs,
631 -- but they'll already be in the environment.
633 -- Typecheck the methods
634 let -- These insts are in scope; quite a few, eh?
635 dfun_insts = dfun_eqs ++ dfun_dicts
636 wanted_sc_insts = wanted_sc_eqs ++ sc_dicts
637 given_sc_eqs = map (updateEqInstCoercion (mkGivenCo . TyVarTy . fromWantedCo "tcInstDecl2") ) wanted_sc_eqs
638 given_sc_insts = given_sc_eqs ++ sc_dicts
639 avail_insts = [this_dict] ++ dfun_insts ++ given_sc_insts
641 tcMethods origin clas inst_tyvars'
642 dfun_theta' inst_tys' avail_insts
643 op_items monobinds uprags `thenM` \ (meth_ids, meth_binds) ->
645 -- Figure out bindings for the superclass context
646 -- Don't include this_dict in the 'givens', else
647 -- wanted_sc_insts get bound by just selecting from this_dict!!
648 addErrCtxt superClassCtxt
649 (tcSimplifySuperClasses inst_loc
650 dfun_insts wanted_sc_insts) `thenM` \ sc_binds ->
652 -- It's possible that the superclass stuff might unified one
653 -- of the inst_tyavars' with something in the envt
654 checkSigTyVars inst_tyvars' `thenM_`
656 -- Deal with 'SPECIALISE instance' pragmas
657 tcPrags dfun_id (filter isSpecInstLSig uprags) `thenM` \ prags ->
659 -- Create the result bindings
661 dict_constr = classDataCon clas
662 scs_and_meths = map instToId sc_dicts ++ meth_ids
663 this_dict_id = instToId this_dict
664 inline_prag | null dfun_insts = []
665 | otherwise = [L loc (InlinePrag (Inline AlwaysActive True))]
666 -- Always inline the dfun; this is an experimental decision
667 -- because it makes a big performance difference sometimes.
668 -- Often it means we can do the method selection, and then
669 -- inline the method as well. Marcin's idea; see comments below.
671 -- BUT: don't inline it if it's a constant dictionary;
672 -- we'll get all the benefit without inlining, and we get
673 -- a **lot** of code duplication if we inline it
675 -- See Note [Inline dfuns] below
678 = mkHsConApp dict_constr (inst_tys' ++ mkTyVarTys sc_covars) (map HsVar scs_and_meths)
679 -- We don't produce a binding for the dict_constr; instead we
680 -- rely on the simplifier to unfold this saturated application
681 -- We do this rather than generate an HsCon directly, because
682 -- it means that the special cases (e.g. dictionary with only one
683 -- member) are dealt with by the common MkId.mkDataConWrapId code rather
684 -- than needing to be repeated here.
686 dict_bind = noLoc (VarBind this_dict_id dict_rhs)
687 all_binds = dict_bind `consBag` (sc_binds `unionBags` meth_binds)
689 main_bind = noLoc $ AbsBinds
690 (inst_tyvars' ++ dfun_covars)
691 (map instToId dfun_dicts)
692 [(inst_tyvars' ++ dfun_covars, dfun_id, this_dict_id, inline_prag ++ prags)]
695 showLIE (text "instance") `thenM_`
696 returnM (unitBag main_bind)
698 mkCoVars :: [PredType] -> TcM [TyVar]
699 mkCoVars [] = return []
700 mkCoVars (pred:preds) =
701 do { uniq <- newUnique
702 ; let name = mkSysTvName uniq FSLIT("mkCoVars")
703 ; let tv = mkCoVar name (PredTy pred)
704 ; tvs <- mkCoVars preds
708 mkMetaCoVars :: [PredType] -> TcM [TyVar]
709 mkMetaCoVars [] = return []
710 mkMetaCoVars (EqPred ty1 ty2:preds) =
711 do { tv <- newMetaTyVar TauTv (mkCoKind ty1 ty2)
712 ; tvs <- mkMetaCoVars preds
717 tcMethods origin clas inst_tyvars' dfun_theta' inst_tys'
718 avail_insts op_items monobinds uprags
719 = -- Check that all the method bindings come from this class
721 sel_names = [idName sel_id | (sel_id, _) <- op_items]
722 bad_bndrs = collectHsBindBinders monobinds `minusList` sel_names
724 mappM (addErrTc . badMethodErr clas) bad_bndrs `thenM_`
726 -- Make the method bindings
728 mk_method_bind = mkMethodBind origin clas inst_tys' monobinds
730 mapAndUnzipM mk_method_bind op_items `thenM` \ (meth_insts, meth_infos) ->
732 -- And type check them
733 -- It's really worth making meth_insts available to the tcMethodBind
734 -- Consider instance Monad (ST s) where
735 -- {-# INLINE (>>) #-}
736 -- (>>) = ...(>>=)...
737 -- If we don't include meth_insts, we end up with bindings like this:
738 -- rec { dict = MkD then bind ...
739 -- then = inline_me (... (GHC.Base.>>= dict) ...)
741 -- The trouble is that (a) 'then' and 'dict' are mutually recursive,
742 -- and (b) the inline_me prevents us inlining the >>= selector, which
743 -- would unravel the loop. Result: (>>) ends up as a loop breaker, and
744 -- is not inlined across modules. Rather ironic since this does not
745 -- happen without the INLINE pragma!
747 -- Solution: make meth_insts available, so that 'then' refers directly
748 -- to the local 'bind' rather than going via the dictionary.
750 -- BUT WATCH OUT! If the method type mentions the class variable, then
751 -- this optimisation is not right. Consider
755 -- instance C Int where
757 -- The occurrence of 'op' on the rhs gives rise to a constraint
759 -- The trouble is that the 'meth_inst' for op, which is 'available', also
760 -- looks like 'op at Int'. But they are not the same.
762 prag_fn = mkPragFun uprags
763 all_insts = avail_insts ++ catMaybes meth_insts
764 sig_fn n = Just [] -- No scoped type variables, but every method has
765 -- a type signature, in effect, so that we check
766 -- the method has the right type
767 tc_method_bind = tcMethodBind inst_tyvars' dfun_theta' all_insts sig_fn prag_fn
768 meth_ids = [meth_id | (_,meth_id,_) <- meth_infos]
771 mapM tc_method_bind meth_infos `thenM` \ meth_binds_s ->
773 returnM (meth_ids, unionManyBags meth_binds_s)
777 ------------------------------
778 [Inline dfuns] Inlining dfuns unconditionally
779 ------------------------------
781 The code above unconditionally inlines dict funs. Here's why.
782 Consider this program:
784 test :: Int -> Int -> Bool
785 test x y = (x,y) == (y,x) || test y x
786 -- Recursive to avoid making it inline.
788 This needs the (Eq (Int,Int)) instance. If we inline that dfun
789 the code we end up with is good:
792 \r -> case ==# [ww ww1] of wild {
793 PrelBase.False -> Test.$wtest ww1 ww;
795 case ==# [ww1 ww] of wild1 {
796 PrelBase.False -> Test.$wtest ww1 ww;
797 PrelBase.True -> PrelBase.True [];
800 Test.test = \r [w w1]
803 case w1 of w3 { PrelBase.I# ww1 -> Test.$wtest ww ww1; };
806 If we don't inline the dfun, the code is not nearly as good:
808 (==) = case PrelTup.$fEq(,) PrelBase.$fEqInt PrelBase.$fEqInt of tpl {
809 PrelBase.:DEq tpl1 tpl2 -> tpl2;
814 let { y = PrelBase.I#! [ww1]; } in
815 let { x = PrelBase.I#! [ww]; } in
816 let { sat_slx = PrelTup.(,)! [y x]; } in
817 let { sat_sly = PrelTup.(,)! [x y];
819 case == sat_sly sat_slx of wild {
820 PrelBase.False -> Test.$wtest ww1 ww;
821 PrelBase.True -> PrelBase.True [];
828 case w1 of w3 { PrelBase.I# ww1 -> Test.$wtest ww ww1; };
831 Why doesn't GHC inline $fEq? Because it looks big:
833 PrelTup.zdfEqZ1T{-rcX-}
834 = \ @ a{-reT-} :: * @ b{-reS-} :: *
835 zddEq{-rf6-} _Ks :: {PrelBase.Eq{-23-} a{-reT-}}
836 zddEq1{-rf7-} _Ks :: {PrelBase.Eq{-23-} b{-reS-}} ->
838 zeze{-rf0-} _Kl :: (b{-reS-} -> b{-reS-} -> PrelBase.Bool{-3c-})
839 zeze{-rf0-} = PrelBase.zeze{-01L-}@ b{-reS-} zddEq1{-rf7-} } in
841 zeze1{-rf3-} _Kl :: (a{-reT-} -> a{-reT-} -> PrelBase.Bool{-3c-})
842 zeze1{-rf3-} = PrelBase.zeze{-01L-} @ a{-reT-} zddEq{-rf6-} } in
844 zeze2{-reN-} :: ((a{-reT-}, b{-reS-}) -> (a{-reT-}, b{-reS-})-> PrelBase.Bool{-3c-})
845 zeze2{-reN-} = \ ds{-rf5-} _Ks :: (a{-reT-}, b{-reS-})
846 ds1{-rf4-} _Ks :: (a{-reT-}, b{-reS-}) ->
848 of wild{-reW-} _Kd { (a1{-rf2-} _Ks, a2{-reZ-} _Ks) ->
850 of wild1{-reX-} _Kd { (b1{-rf1-} _Ks, b2{-reY-} _Ks) ->
852 (zeze1{-rf3-} a1{-rf2-} b1{-rf1-})
853 (zeze{-rf0-} a2{-reZ-} b2{-reY-})
857 a1{-reR-} :: ((a{-reT-}, b{-reS-})-> (a{-reT-}, b{-reS-})-> PrelBase.Bool{-3c-})
858 a1{-reR-} = \ a2{-reV-} _Ks :: (a{-reT-}, b{-reS-})
859 b1{-reU-} _Ks :: (a{-reT-}, b{-reS-}) ->
860 PrelBase.not{-r6I-} (zeze2{-reN-} a2{-reV-} b1{-reU-})
862 PrelBase.zdwZCDEq{-r8J-} @ (a{-reT-}, b{-reS-}) a1{-reR-} zeze2{-reN-})
864 and it's not as bad as it seems, because it's further dramatically
865 simplified: only zeze2 is extracted and its body is simplified.
868 %************************************************************************
870 \subsection{Error messages}
872 %************************************************************************
875 instDeclCtxt1 hs_inst_ty
876 = inst_decl_ctxt (case unLoc hs_inst_ty of
877 HsForAllTy _ _ _ (L _ (HsPredTy pred)) -> ppr pred
878 HsPredTy pred -> ppr pred
879 other -> ppr hs_inst_ty) -- Don't expect this
880 instDeclCtxt2 dfun_ty
881 = inst_decl_ctxt (ppr (mkClassPred cls tys))
883 (_,_,cls,tys) = tcSplitDFunTy dfun_ty
885 inst_decl_ctxt doc = ptext SLIT("In the instance declaration for") <+> quotes doc
887 superClassCtxt = ptext SLIT("When checking the super-classes of an instance declaration")
889 atInstCtxt name = ptext SLIT("In the associated type instance for") <+>
893 sep [ ptext SLIT("Arguments that do not correspond to a class parameter") <+>
894 ptext SLIT("must be variables")
895 , ptext SLIT("Instead of a variable, found") <+> ppr ty
898 wrongATArgErr ty instTy =
899 sep [ ptext SLIT("Type indexes must match class instance head")
900 , ptext SLIT("Found") <+> ppr ty <+> ptext SLIT("but expected") <+>