MonoBinds(..), HsExpr(..), HsLit(..), Sig(..),
andMonoBindList, collectMonoBinders, isClassDecl
)
-import RnHsSyn ( RenamedHsBinds, RenamedInstDecl, RenamedHsDecl, RenamedMonoBinds,
- RenamedTyClDecl, RenamedHsType,
+import RnHsSyn ( RenamedHsBinds, RenamedInstDecl, RenamedHsDecl,
+ RenamedMonoBinds, RenamedTyClDecl, RenamedHsType,
extractHsTyVars, maybeGenericMatch
)
import TcHsSyn ( TcMonoBinds, mkHsConApp )
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 )
-> [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) $
| null errs = returnTc ()
| otherwise = addErrsTc errs `thenNF_Tc_` failTc
where
- errs = checkInstHead dflags clas inst_tys ++
+ errs = checkInstHead dflags theta clas inst_tys ++
[err | pred <- theta, err <- checkInstConstraint dflags pred]
checkInstConstraint dflags pred
| otherwise
= [instConstraintErr pred]
-checkInstHead dflags clas inst_taus
+checkInstHead dflags theta clas inst_taus
| -- CCALL CHECK
-- A user declaration of a CCallable/CReturnable instance
-- must be for a "boxed primitive" type.
-- If GlasgowExts then check at least one isn't a type variable
| dopt Opt_GlasgowExts dflags
= -- GlasgowExts case
- check_tyvars dflags clas inst_taus ++ check_fundeps dflags clas inst_taus
+ check_tyvars dflags clas inst_taus ++ check_fundeps dflags theta clas inst_taus
-- WITH HASKELL 1.4, MUST HAVE C (T a b c)
| not (length inst_taus == 1 &&
the_err = instTypeErr clas inst_taus msg
msg = ptext SLIT("There must be at least one non-type-variable in the instance head")
-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")