Don't use the same simplify code for both restricted and unrestricted
bindings. In particular, a restricted binding shouldn't try to capture
implicit params.
import TcEnv ( tcExtendLocalValEnv,
newSpecPragmaId, newLocalId
)
import TcEnv ( tcExtendLocalValEnv,
newSpecPragmaId, newLocalId
)
-import TcSimplify ( tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyCheck, tcSimplifyToDicts )
+import TcSimplify ( tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyCheck, tcSimplifyRestricted, tcSimplifyToDicts )
import TcMonoType ( tcHsSigType, checkSigTyVars,
TcSigInfo(..), tcTySig, maybeSig, sigCtxt
)
import TcMonoType ( tcHsSigType, checkSigTyVars,
TcSigInfo(..), tcTySig, maybeSig, sigCtxt
)
+ traceTc (text "binding:" <+> ppr ((zonked_dict_ids, dict_binds),
+ exports, [idType poly_id | (_, poly_id, _) <- exports])) `thenTc_`
+
-- BUILD RESULTS
returnTc (
-- BUILD RESULTS
returnTc (
- -- pprTrace "binding.." (ppr ((zonked_dict_ids, dict_binds),
- -- exports, [idType poly_id | (_, poly_id, _) <- exports])) $
AbsBinds real_tyvars_to_gen
zonked_dict_ids
exports
AbsBinds real_tyvars_to_gen
zonked_dict_ids
exports
-- Now simplify with exactly that set of tyvars
-- We have to squash those Methods
-- Now simplify with exactly that set of tyvars
-- We have to squash those Methods
- tcSimplifyCheck doc final_forall_tvs [] lie_req `thenTc` \ (lie_free, binds) ->
+ tcSimplifyRestricted doc final_forall_tvs [] lie_req `thenTc` \ (lie_free, binds) ->
returnTc (final_forall_tvs, lie_free, binds, [])
returnTc (final_forall_tvs, lie_free, binds, [])
\begin{code}
module TcSimplify (
\begin{code}
module TcSimplify (
- tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyCheck,
+ tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyCheck,
+ tcSimplifyRestricted,
tcSimplifyToDicts, tcSimplifyIPs, tcSimplifyTop,
tcSimplifyThetas, tcSimplifyCheckThetas,
tcSimplifyToDicts, tcSimplifyIPs, tcSimplifyTop,
tcSimplifyThetas, tcSimplifyCheckThetas,
TcDictBinds) -- Bindings
tcSimplifyCheck doc qtvs givens wanted_lie
TcDictBinds) -- Bindings
tcSimplifyCheck doc qtvs givens wanted_lie
- = checkLoop doc qtvs givens (lieToList wanted_lie) `thenTc` \ (frees, binds, irreds) ->
+ = checkLoop doc qtvs givens (lieToList wanted_lie) try `thenTc` \ (frees, binds, irreds) ->
-- Complain about any irreducible ones
complainCheck doc givens irreds `thenNF_Tc_`
-- Done
returnTc (mkLIE frees, binds)
-- Complain about any irreducible ones
complainCheck doc givens irreds `thenNF_Tc_`
-- Done
returnTc (mkLIE frees, binds)
+ where
+ -- When checking against a given signature we always reduce
+ -- until we find a match against something given, or can't reduce
+ try qtvs inst | isFree qtvs inst = Free
+ | otherwise = ReduceMe
-checkLoop doc qtvs givens wanteds
- = -- Step 1
+tcSimplifyRestricted doc qtvs givens wanted_lie
+ = checkLoop doc qtvs givens (lieToList wanted_lie) try `thenTc` \ (frees, binds, irreds) ->
+
+ -- Complain about any irreducible ones
+ complainCheck doc givens irreds `thenNF_Tc_`
+
+ -- Done
+ returnTc (mkLIE frees, binds)
+ where
+ try qtvs inst | not (tyVarsOfInst inst `intersectsVarSet` qtvs) = Free
+ | otherwise = ReduceMe
+
+checkLoop doc qtvs givens wanteds try_me
+ = -- Step 1
zonkTcTyVarsAndFV qtvs `thenNF_Tc` \ qtvs' ->
mapNF_Tc zonkInst givens `thenNF_Tc` \ givens' ->
mapNF_Tc zonkInst wanteds `thenNF_Tc` \ wanteds' ->
zonkTcTyVarsAndFV qtvs `thenNF_Tc` \ qtvs' ->
mapNF_Tc zonkInst givens `thenNF_Tc` \ givens' ->
mapNF_Tc zonkInst wanteds `thenNF_Tc` \ wanteds' ->
- let
- -- When checking against a given signature we always reduce
- -- until we find a match against something given, or can't reduce
- try_me inst | isFree qtvs' inst = Free
- | otherwise = ReduceMe
- in
- reduceContext doc try_me givens' wanteds' `thenTc` \ (no_improvement, frees, binds, irreds) ->
+ reduceContext doc (try_me qtvs') givens' wanteds' `thenTc` \ (no_improvement, frees, binds, irreds) ->
-- Step 3
if no_improvement then
returnTc (frees, binds, irreds)
else
-- Step 3
if no_improvement then
returnTc (frees, binds, irreds)
else
- checkLoop doc qtvs givens' (irreds ++ frees) `thenTc` \ (frees1, binds1, irreds1) ->
+ checkLoop doc qtvs givens' (irreds ++ frees) try_me `thenTc` \ (frees1, binds1, irreds1) ->
returnTc (frees1, binds `AndMonoBinds` binds1, irreds1)
complainCheck doc givens irreds
returnTc (frees1, binds `AndMonoBinds` binds1, irreds1)
complainCheck doc givens irreds