import HsSyn ( HsDecl(..), InstDecl(..), TyClDecl(..), HsType(..),
MonoBinds(..), HsExpr(..), HsLit(..), Sig(..),
- andMonoBindList, collectMonoBinders, isClassDecl
+ andMonoBindList, collectMonoBinders, isClassDecl, toHsType
)
import RnHsSyn ( RenamedHsBinds, RenamedInstDecl, RenamedHsDecl,
RenamedMonoBinds, RenamedTyClDecl, RenamedHsType,
import TcMonad
import TcType ( tcInstType )
import Inst ( InstOrigin(..),
- newDicts, newClassDicts, instToId,
+ newDicts, instToId,
LIE, mkLIE, emptyLIE, plusLIE, plusLIEs )
import TcDeriv ( tcDeriving )
import TcEnv ( TcEnv, tcExtendGlobalValEnv,
import Generics ( validGenericInstanceType )
import Module ( Module, foldModuleEnv )
import Name ( getSrcLoc )
-import NameSet ( emptyNameSet, nameSetToList )
+import NameSet ( emptyNameSet, unitNameSet, nameSetToList )
import PrelInfo ( eRROR_ID )
import PprType ( pprClassPred, pprPred )
import TyCon ( TyCon, isSynTyCon )
splitTyConApp_maybe, splitDictTy,
splitForAllTys,
tyVarsOfTypes, mkClassPred, mkTyVarTy,
- getClassTys_maybe
+ isTyVarClassPred, inheritablePred
)
-import Subst ( mkTopTyVarSubst, substClasses )
+import Subst ( mkTopTyVarSubst, substTheta )
import VarSet ( varSetElems )
import TysWiredIn ( genericTyCons, isFFIArgumentTy, isFFIImportResultTy )
import PrelNames ( cCallableClassKey, cReturnableClassKey, hasKey )
tcInstDecl2 (InstInfo { iDFunId = dfun_id,
iBinds = monobinds, iPrags = uprags })
= -- Prime error recovery
- recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds)) $
- tcAddSrcLoc (getSrcLoc dfun_id) $
+ recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds)) $
+ tcAddSrcLoc (getSrcLoc dfun_id) $
+ tcAddErrCtxt (instDeclCtxt (toHsType (idType dfun_id))) $
-- Instantiate the instance decl with tc-style type variables
tcInstType (idType dfun_id) `thenNF_Tc` \ (inst_tyvars', dfun_theta', dict_ty') ->
sel_names = [idName sel_id | (sel_id, _) <- op_items]
-- Instantiate the super-class context with inst_tys
- sc_theta' = substClasses (mkTopTyVarSubst class_tyvars inst_tys') sc_theta
+ sc_theta' = substTheta (mkTopTyVarSubst class_tyvars inst_tys') sc_theta
-- Find any definitions in monobinds that aren't from the class
bad_bndrs = collectMonoBinders monobinds `minusList` sel_names
mapTc (addErrTc . badMethodErr clas) bad_bndrs `thenNF_Tc_`
-- Create dictionary Ids from the specified instance contexts.
- newClassDicts origin sc_theta' `thenNF_Tc` \ sc_dicts ->
- newDicts origin dfun_theta' `thenNF_Tc` \ dfun_arg_dicts ->
- newClassDicts origin [(clas,inst_tys')] `thenNF_Tc` \ [this_dict] ->
+ newDicts origin sc_theta' `thenNF_Tc` \ sc_dicts ->
+ newDicts origin dfun_theta' `thenNF_Tc` \ dfun_arg_dicts ->
+ newDicts origin [mkClassPred clas inst_tys'] `thenNF_Tc` \ [this_dict] ->
tcExtendTyVarEnvForMeths inst_tyvars inst_tyvars' (
tcExtendGlobalValEnv dm_ids (
dict_constr = classDataCon clas
scs_and_meths = map instToId (sc_dicts ++ meth_insts)
this_dict_id = instToId this_dict
+ inlines = unitNameSet (idName dfun_id)
+ -- Always inline the dfun; this is an experimental decision
+ -- because it makes a big performance difference sometimes.
+ -- Often it means we can do the method selection, and then
+ -- inline the method as well. Marcin's idea.
dict_rhs
| null scs_and_meths
zonked_inst_tyvars
(map instToId dfun_arg_dicts)
[(inst_tyvars', dfun_id, this_dict_id)]
- emptyNameSet -- No inlines (yet)
+ inlines
(lie_binds1 `AndMonoBinds`
lie_binds2 `AndMonoBinds`
method_binds `AndMonoBinds`
[err | pred <- theta, err <- checkInstConstraint dflags pred]
checkInstConstraint dflags pred
- | dopt Opt_AllowUndecidableInstances dflags
- = []
+ -- Checks whether a predicate is legal in the
+ -- context of an instance declaration
+ | ok = []
+ | otherwise = [instConstraintErr pred]
+ where
+ ok = inheritablePred pred &&
+ (isTyVarClassPred pred || arbitrary_preds_ok)
- | Just (clas,tys) <- getClassTys_maybe pred,
- all isTyVarTy tys
- = []
+ arbitrary_preds_ok = dopt Opt_AllowUndecidableInstances dflags
- | otherwise
- = [instConstraintErr pred]
checkInstHead dflags theta clas inst_taus
| -- CCALL CHECK
| otherwise = [the_err]
where
the_err = instTypeErr clas inst_taus msg
- msg = ptext SLIT("There must be at least one non-type-variable in the instance head")
+ msg = ptext SLIT("There must be at least one non-type-variable in the instance head")
+ $$ ptext SLIT("Use -fallow-undecidable-instances to lift this restriction")
check_fundeps dflags theta clas inst_taus
| checkInstFDs theta clas inst_taus = []