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 RnHsSyn ( RenamedHsBinds, RenamedInstDecl, RenamedHsDecl,
+ RenamedMonoBinds, RenamedTyClDecl, RenamedHsType,
extractHsTyVars, maybeGenericMatch
)
import TcHsSyn ( TcMonoBinds, mkHsConApp )
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,
tcExtendTyVarEnvForMeths,
tcAddImportedIdInfo, tcLookupClass,
- InstInfo(..), pprInstInfo, simpleInstInfoTyCon, simpleInstInfoTy,
- newDFunName, tcExtendTyVarEnv
+ InstInfo(..), pprInstInfo, simpleInstInfoTyCon,
+ simpleInstInfoTy, newDFunName, tcExtendTyVarEnv,
+ isLocalThing,
)
import InstEnv ( InstEnv, extendInstEnv )
import TcMonoType ( tcTyVars, tcHsSigType, kcHsSigType, checkSigTyVars )
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 )
-> [RenamedHsDecl]
-> TcM (PackageInstEnv, InstEnv, [InstInfo], RenamedHsBinds)
-tcInstDecls1 inst_env0 prs hst unf_env get_fixity mod decls
+tcInstDecls1 inst_env0 prs hst unf_env get_fixity this_mod decls
= let
inst_decls = [inst_decl | InstD inst_decl <- decls]
tycl_decls = [decl | TyClD decl <- decls]
clas_decls = filter isClassDecl tycl_decls
in
-- (1) Do the ordinary instance declarations
- mapNF_Tc (tcInstDecl1 unf_env) inst_decls `thenNF_Tc` \ inst_infos ->
+ mapNF_Tc tcInstDecl1 inst_decls `thenNF_Tc` \ inst_infos ->
-- (2) Instances from generic class declarations
getGenericInstances clas_decls `thenTc` \ generic_inst_info ->
-- e) generic instances inst_env4
-- The result of (b) replaces the cached InstEnv in the PCS
let
- (local_inst_info, imported_inst_info) = partition iLocal (concat inst_infos)
+ (local_inst_info, imported_inst_info)
+ = partition (isLocalThing this_mod . iDFunId) (concat inst_infos)
imported_dfuns = map (tcAddImportedIdInfo unf_env . iDFunId)
imported_inst_info
-- we ignore deriving decls from interfaces!
-- This stuff computes a context for the derived instance decl, so it
-- needs to know about all the instances possible; hecne inst_env4
- tcDeriving prs mod inst_env4 get_fixity tycl_decls `thenTc` \ (deriv_inst_info, deriv_binds) ->
+ tcDeriving prs this_mod inst_env4 get_fixity tycl_decls
+ `thenTc` \ (deriv_inst_info, deriv_binds) ->
addInstInfos inst_env4 deriv_inst_info `thenNF_Tc` \ final_inst_env ->
returnTc (inst_env1,
\end{code}
\begin{code}
-tcInstDecl1 :: TcEnv -> RenamedInstDecl -> NF_TcM [InstInfo]
+tcInstDecl1 :: RenamedInstDecl -> NF_TcM [InstInfo]
-- Deal with a single instance declaration
-tcInstDecl1 unf_env decl@(InstDecl poly_ty binds uprags maybe_dfun_name src_loc)
+tcInstDecl1 decl@(InstDecl poly_ty binds uprags maybe_dfun_name src_loc)
= -- Prime error recovery, set source location
recoverNF_Tc (returnNF_Tc []) $
tcAddSrcLoc src_loc $
let
dfun_id = mkDictFunId dfun_name clas tyvars inst_tys theta
in
- returnTc [InstInfo { iLocal = is_local, iDFunId = dfun_id,
+ returnTc [InstInfo { iDFunId = dfun_id,
iBinds = binds, iPrags = uprags }]
\end{code}
let
gen_inst_info = concat gen_inst_infos
in
+ if null gen_inst_info then
+ returnTc []
+ else
getDOptsTc `thenTc` \ dflags ->
ioToTc (dumpIfSet_dyn dflags Opt_D_dump_deriv "Generic instances"
(vcat (map pprInstInfo gen_inst_info)))
dfun_id = mkDictFunId dfun_name clas tyvars inst_tys inst_theta
in
- returnTc (InstInfo { iLocal = True, iDFunId = dfun_id,
+ returnTc (InstInfo { iDFunId = dfun_id,
iBinds = binds, iPrags = [] })
\end{code}
First comes the easy case of a non-local instance decl.
+
\begin{code}
tcInstDecl2 :: InstInfo -> NF_TcM (LIE, TcMonoBinds)
+-- tcInstDecl2 is called *only* on InstInfos
-tcInstDecl2 (InstInfo { iLocal = is_local, iDFunId = dfun_id,
+tcInstDecl2 (InstInfo { iDFunId = dfun_id,
iBinds = monobinds, iPrags = uprags })
- | not is_local
- = returnNF_Tc (emptyLIE, EmptyMonoBinds)
-
- | otherwise
= -- 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 = []
projects / ghc-hetmet.git / blobdiff