Commit ebf2c802 authored by lewie's avatar lewie
Browse files

[project @ 2001-04-12 21:29:43 by lewie]

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.
parent 9484150a
...@@ -27,7 +27,7 @@ import Inst ( LIE, emptyLIE, mkLIE, plusLIE, InstOrigin(..), ...@@ -27,7 +27,7 @@ import Inst ( LIE, emptyLIE, mkLIE, plusLIE, InstOrigin(..),
import TcEnv ( tcExtendLocalValEnv, import TcEnv ( tcExtendLocalValEnv,
newSpecPragmaId, newLocalId newSpecPragmaId, newLocalId
) )
import TcSimplify ( tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyCheck, tcSimplifyToDicts ) import TcSimplify ( tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyCheck, tcSimplifyRestricted, tcSimplifyToDicts )
import TcMonoType ( tcHsSigType, checkSigTyVars, import TcMonoType ( tcHsSigType, checkSigTyVars,
TcSigInfo(..), tcTySig, maybeSig, sigCtxt TcSigInfo(..), tcTySig, maybeSig, sigCtxt
) )
...@@ -289,10 +289,11 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec ...@@ -289,10 +289,11 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec
-- at all. -- at all.
in in
traceTc (text "binding:" <+> ppr ((zonked_dict_ids, dict_binds),
exports, [idType poly_id | (_, poly_id, _) <- exports])) `thenTc_`
-- BUILD RESULTS -- BUILD RESULTS
returnTc ( returnTc (
-- pprTrace "binding.." (ppr ((zonked_dict_ids, dict_binds),
-- exports, [idType poly_id | (_, poly_id, _) <- exports])) $
AbsBinds real_tyvars_to_gen AbsBinds real_tyvars_to_gen
zonked_dict_ids zonked_dict_ids
exports exports
...@@ -462,7 +463,7 @@ generalise binder_names mbind tau_tvs lie_req sigs ...@@ -462,7 +463,7 @@ generalise binder_names mbind tau_tvs lie_req sigs
-- Now simplify with exactly that set of tyvars -- Now simplify with exactly that set of tyvars
-- We have to squash those Methods -- 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, [])
......
...@@ -8,6 +8,7 @@ ...@@ -8,6 +8,7 @@
\begin{code} \begin{code}
module TcSimplify ( module TcSimplify (
tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyCheck, tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyCheck,
tcSimplifyRestricted,
tcSimplifyToDicts, tcSimplifyIPs, tcSimplifyTop, tcSimplifyToDicts, tcSimplifyIPs, tcSimplifyTop,
tcSimplifyThetas, tcSimplifyCheckThetas, tcSimplifyThetas, tcSimplifyCheckThetas,
...@@ -479,33 +480,45 @@ tcSimplifyCheck ...@@ -479,33 +480,45 @@ tcSimplifyCheck
TcDictBinds) -- Bindings TcDictBinds) -- Bindings
tcSimplifyCheck doc qtvs givens wanted_lie 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 -- Complain about any irreducible ones
complainCheck doc givens irreds `thenNF_Tc_` complainCheck doc givens irreds `thenNF_Tc_`
-- Done -- Done
returnTc (mkLIE frees, binds) 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
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 checkLoop doc qtvs givens wanteds try_me
= -- Step 1 = -- Step 1
zonkTcTyVarsAndFV qtvs `thenNF_Tc` \ qtvs' -> zonkTcTyVarsAndFV qtvs `thenNF_Tc` \ qtvs' ->
mapNF_Tc zonkInst givens `thenNF_Tc` \ givens' -> mapNF_Tc zonkInst givens `thenNF_Tc` \ givens' ->
mapNF_Tc zonkInst wanteds `thenNF_Tc` \ wanteds' -> 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
-- Step 2 -- Step 2
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 -- Step 3
if no_improvement then if no_improvement then
returnTc (frees, binds, irreds) returnTc (frees, binds, irreds)
else 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) returnTc (frees1, binds `AndMonoBinds` binds1, irreds1)
complainCheck doc givens irreds complainCheck doc givens irreds
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment