diff options
| author | Simon Peyton Jones <simonpj@microsoft.com> | 2014-10-29 15:34:14 +0000 |
|---|---|---|
| committer | Simon Peyton Jones <simonpj@microsoft.com> | 2014-10-31 09:08:42 +0000 |
| commit | 68d3377644a25b0428d09a1135e5b30bb0a32fbd (patch) | |
| tree | 85a7ae1594d05f736df19ece7454eb636f9afe52 | |
| parent | e4a0a3ed8a2ac8462794a1c3b5bad4da08c3680d (diff) | |
| download | haskell-68d3377644a25b0428d09a1135e5b30bb0a32fbd.tar.gz | |
Simplify the generation of superclass constraints in tcInstDecl2
The simplified function is tcSuperClasses;
no need for an implication constraint here
| -rw-r--r-- | compiler/typecheck/TcInstDcls.lhs | 19 |
1 files changed, 10 insertions, 9 deletions
diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index b986fa8c2f..a471e11732 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -840,7 +840,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) ; dfun_ev_vars <- newEvVars dfun_theta - ; (sc_binds, sc_ev_vars) <- tcSuperClasses dfun_id inst_tyvars dfun_ev_vars sc_theta' + ; sc_ev_vars <- tcSuperClasses dfun_id inst_tyvars dfun_ev_vars sc_theta' -- Deal with 'SPECIALISE instance' pragmas -- See Note [SPECIALISE instance pragmas] @@ -908,7 +908,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) main_bind = AbsBinds { abs_tvs = inst_tyvars , abs_ev_vars = dfun_ev_vars , abs_exports = [export] - , abs_ev_binds = sc_binds + , abs_ev_binds = emptyTcEvBinds , abs_binds = unitBag dict_bind } ; return (unitBag (L loc main_bind) `unionBags` @@ -920,22 +920,23 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) ------------------------------ tcSuperClasses :: DFunId -> [TcTyVar] -> [EvVar] -> TcThetaType - -> TcM (TcEvBinds, [EvVar]) + -> TcM [EvVar] -- See Note [Silent superclass arguments] tcSuperClasses dfun_id inst_tyvars dfun_ev_vars sc_theta + | null inst_tyvars && null dfun_ev_vars + = emitWanteds ScOrigin sc_theta + + | otherwise = do { -- Check that all superclasses can be deduced from -- the originally-specified dfun arguments - ; (sc_binds, sc_evs) <- checkConstraints InstSkol inst_tyvars orig_ev_vars $ - emitWanteds ScOrigin sc_theta + ; _ <- checkConstraints InstSkol inst_tyvars orig_ev_vars $ + emitWanteds ScOrigin sc_theta - ; if null inst_tyvars && null dfun_ev_vars - then return (sc_binds, sc_evs) - else return (emptyTcEvBinds, sc_lam_args) } + ; return (map (find dfun_ev_vars) sc_theta) } where n_silent = dfunNSilent dfun_id orig_ev_vars = drop n_silent dfun_ev_vars - sc_lam_args = map (find dfun_ev_vars) sc_theta find [] pred = pprPanic "tcInstDecl2" (ppr dfun_id $$ ppr (idType dfun_id) $$ ppr pred) find (ev:evs) pred |