import TyCon ( TyCon, isSynTyCon )
import Type ( splitDFunTy, isTyVarTy,
splitTyConApp_maybe, splitDictTy,
- splitAlgTyConApp_maybe, splitForAllTys,
- unUsgTy, tyVarsOfTypes, mkClassPred, mkTyVarTy,
+ splitForAllTys,
+ tyVarsOfTypes, mkClassPred, mkTyVarTy,
getClassTys_maybe
)
import Subst ( mkTopTyVarSubst, substClasses )
-> TcEnv -- Contains IdInfo for dfun ids
-> (Name -> Maybe Fixity) -- for deriving Show and Read
-> Module -- Module for deriving
- -> [TyCon]
-> [RenamedHsDecl]
-> TcM (PackageInstEnv, InstEnv, [InstInfo], RenamedHsBinds)
-tcInstDecls1 inst_env0 prs hst unf_env get_fixity mod tycons decls
+tcInstDecls1 inst_env0 prs hst unf_env get_fixity mod decls
= let
inst_decls = [inst_decl | InstD inst_decl <- decls]
tycl_decls = [decl | TyClD decl <- decls]
addInstDFuns :: InstEnv -> [DFunId] -> NF_TcM InstEnv
addInstDFuns dfuns infos
= getDOptsTc `thenTc` \ dflags ->
- extendInstEnv dflags dfuns infos `bind` \ (inst_env', errs) ->
+ let
+ (inst_env', errs) = extendInstEnv dflags dfuns infos
+ in
addErrsTc errs `thenNF_Tc_`
returnTc inst_env'
- where
- bind x f = f x
-
\end{code}
\begin{code}
= plusAssoc_C AndMonoBinds (getGenericBinds m1) (getGenericBinds m2)
getGenericBinds (FunMonoBind id infixop matches loc)
- = mapAssoc wrap (foldr add emptyAssoc matches)
+ = mapAssoc wrap (foldl add emptyAssoc matches)
+ -- Using foldl not foldr is vital, else
+ -- we reverse the order of the bindings!
where
- add match env = case maybeGenericMatch match of
+ add env match = case maybeGenericMatch match of
Nothing -> env
Just (ty, match') -> extendAssoc_C (++) env (ty, [match'])
methods_lie = plusLIEs insts_needed_s
in
- -- Ditto method bindings
+ -- Simplify the constraints from methods
tcAddErrCtxt methodCtxt (
tcSimplifyAndCheck
(ptext SLIT("instance declaration context"))
methods_lie
) `thenTc` \ (const_lie1, lie_binds1) ->
- -- Now do the simplification again, this time to get the
- -- bindings; this time we use an enhanced "avails"
- -- Ignore errors because they come from the *previous* tcSimplify
- discardErrsTc (
- tcSimplifyAndCheck
+ -- Figure out bindings for the superclass context
+ tcAddErrCtxt superClassCtxt (
+ tcSimplifyAndCheck
(ptext SLIT("instance declaration context"))
inst_tyvars_set
dfun_arg_dicts -- NB! Don't include this_dict here, else the sc_dicts
-- emit an error message. This in turn means that we don't
-- mention the constructor, which doesn't exist for CCallable, CReturnable
-- Hardly beautiful, but only three extra lines.
- HsApp (TyApp (HsVar eRROR_ID) [(unUsgTy . idType) this_dict_id])
+ HsApp (TyApp (HsVar eRROR_ID) [idType this_dict_id])
(HsLit (HsString msg))
| otherwise -- The common case
maybe_tycon_app = splitTyConApp_maybe first_inst_tau
Just (tycon, arg_tys) = maybe_tycon_app
- -- Stuff for an *algebraic* data type
- alg_tycon_app_maybe = splitAlgTyConApp_maybe first_inst_tau
- -- The "Alg" part looks through synonyms
- Just (alg_tycon, _, _) = alg_tycon_app_maybe
-
ccallable_type dflags ty = isFFIArgumentTy dflags False {- Not safe call -} ty
creturnable_type ty = isFFIResultTy ty
\end{code}
ppr inst_ty])
methodCtxt = ptext SLIT("When checking the methods of an instance declaration")
+superClassCtxt = ptext SLIT("When checking the super-classes of an instance declaration")
\end{code}
-
-