import HsSyn ( HsDecl(..), InstDecl(..), TyClDecl(..), HsType(..),
MonoBinds(..), HsExpr(..), HsLit(..), Sig(..),
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 )
extractHsTyVars, maybeGenericMatch
)
import TcHsSyn ( TcMonoBinds, mkHsConApp )
import TcMonad
import TcType ( tcInstType )
import Inst ( InstOrigin(..),
import TcMonad
import TcType ( tcInstType )
import Inst ( InstOrigin(..),
LIE, mkLIE, emptyLIE, plusLIE, plusLIEs )
import TcDeriv ( tcDeriving )
import TcEnv ( TcEnv, tcExtendGlobalValEnv,
tcExtendTyVarEnvForMeths,
tcAddImportedIdInfo, tcLookupClass,
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 InstEnv ( InstEnv, extendInstEnv )
import TcMonoType ( tcTyVars, tcHsSigType, kcHsSigType, checkSigTyVars )
import Generics ( validGenericInstanceType )
import Module ( Module, foldModuleEnv )
import Name ( getSrcLoc )
import Generics ( validGenericInstanceType )
import Module ( Module, foldModuleEnv )
import Name ( getSrcLoc )
import PrelInfo ( eRROR_ID )
import PprType ( pprClassPred, pprPred )
import TyCon ( TyCon, isSynTyCon )
import PrelInfo ( eRROR_ID )
import PprType ( pprClassPred, pprPred )
import TyCon ( TyCon, isSynTyCon )
splitTyConApp_maybe, splitDictTy,
splitForAllTys,
tyVarsOfTypes, mkClassPred, mkTyVarTy,
splitTyConApp_maybe, splitDictTy,
splitForAllTys,
tyVarsOfTypes, mkClassPred, mkTyVarTy,
import VarSet ( varSetElems )
import TysWiredIn ( genericTyCons, isFFIArgumentTy, isFFIImportResultTy )
import PrelNames ( cCallableClassKey, cReturnableClassKey, hasKey )
import VarSet ( varSetElems )
import TysWiredIn ( genericTyCons, isFFIArgumentTy, isFFIImportResultTy )
import PrelNames ( cCallableClassKey, cReturnableClassKey, hasKey )
-> [RenamedHsDecl]
-> TcM (PackageInstEnv, InstEnv, [InstInfo], RenamedHsBinds)
-> [RenamedHsDecl]
-> TcM (PackageInstEnv, InstEnv, [InstInfo], RenamedHsBinds)
= 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
= 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
-- (2) Instances from generic class declarations
getGenericInstances clas_decls `thenTc` \ generic_inst_info ->
-- (2) Instances from generic class declarations
getGenericInstances clas_decls `thenTc` \ generic_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
-- 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) ->
= -- Prime error recovery, set source location
recoverNF_Tc (returnNF_Tc []) $
tcAddSrcLoc src_loc $
= -- Prime error recovery, set source location
recoverNF_Tc (returnNF_Tc []) $
tcAddSrcLoc src_loc $
getDOptsTc `thenTc` \ dflags ->
ioToTc (dumpIfSet_dyn dflags Opt_D_dump_deriv "Generic instances"
(vcat (map pprInstInfo gen_inst_info)))
getDOptsTc `thenTc` \ dflags ->
ioToTc (dumpIfSet_dyn dflags Opt_D_dump_deriv "Generic instances"
(vcat (map pprInstInfo gen_inst_info)))
- 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') ->
-- 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
sel_names = [idName sel_id | (sel_id, _) <- op_items]
-- Instantiate the super-class context with inst_tys
-- Find any definitions in monobinds that aren't from the class
bad_bndrs = collectMonoBinders monobinds `minusList` sel_names
-- 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.
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] ->
dict_constr = classDataCon clas
scs_and_meths = map instToId (sc_dicts ++ meth_insts)
this_dict_id = instToId this_dict
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.
zonked_inst_tyvars
(map instToId dfun_arg_dicts)
[(inst_tyvars', dfun_id, this_dict_id)]
zonked_inst_tyvars
(map instToId dfun_arg_dicts)
[(inst_tyvars', dfun_id, this_dict_id)]
(lie_binds1 `AndMonoBinds`
lie_binds2 `AndMonoBinds`
method_binds `AndMonoBinds`
(lie_binds1 `AndMonoBinds`
lie_binds2 `AndMonoBinds`
method_binds `AndMonoBinds`
[err | pred <- theta, err <- checkInstConstraint dflags pred]
checkInstConstraint dflags pred
[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)
-- WITH HASKELL 1.4, MUST HAVE C (T a b c)
| not (length inst_taus == 1 &&
-- WITH HASKELL 1.4, MUST HAVE C (T a b c)
| not (length inst_taus == 1 &&
-check_fundeps dflags clas inst_taus
- | checkInstFDs clas inst_taus = []
- | otherwise = [the_err]
+check_fundeps dflags theta clas inst_taus
+ | checkInstFDs theta clas inst_taus = []
+ | otherwise = [the_err]
where
the_err = instTypeErr clas inst_taus msg
msg = ptext SLIT("the instance types do not agree with the functional dependencies of the class")
where
the_err = instTypeErr clas inst_taus msg
msg = ptext SLIT("the instance types do not agree with the functional dependencies of the class")