Commit b85ece16 authored by sof's avatar sof
Browse files

[project @ 1997-07-26 02:13:00 by sof]

bug fixes
parent aef1dc96
......@@ -24,7 +24,7 @@ import RnHsSyn ( SYN_IE(RenamedHsBinds), RenamedSig(..),
SYN_IE(RenamedMonoBinds)
)
import TcHsSyn ( SYN_IE(TcHsBinds), SYN_IE(TcMonoBinds),
TcIdOcc(..), SYN_IE(TcIdBndr), SYN_IE(TcExpr),
SYN_IE(TcExpr),
tcIdType
)
......@@ -41,7 +41,8 @@ import TcSimplify ( tcSimplify, tcSimplifyAndCheck )
import TcMonoType ( tcHsType )
import TcPat ( tcPat )
import TcSimplify ( bindInstsOfLocalFuns )
import TcType ( SYN_IE(TcType), SYN_IE(TcThetaType), SYN_IE(TcTauType),
import TcType ( TcIdOcc(..), SYN_IE(TcIdBndr),
SYN_IE(TcType), SYN_IE(TcThetaType), SYN_IE(TcTauType),
SYN_IE(TcTyVarSet), SYN_IE(TcTyVar),
newTyVarTy, zonkTcType, zonkTcTyVar, zonkTcTyVars,
newTcTyVar, tcInstSigType, newTyVarTys
......@@ -58,7 +59,7 @@ import Pretty
import Type ( mkTyVarTy, mkTyVarTys, isTyVarTy, tyVarsOfTypes, eqSimpleTheta,
mkSigmaTy, splitSigmaTy, mkForAllTys, mkFunTys, getTyVar, mkDictTy,
splitRhoTy, mkForAllTy, splitForAllTy )
import TyVar ( GenTyVar, SYN_IE(TyVar), tyVarKind, minusTyVarSet, emptyTyVarSet,
import TyVar ( GenTyVar, SYN_IE(TyVar), tyVarKind, mkTyVarSet, minusTyVarSet, emptyTyVarSet,
elementOfTyVarSet, unionTyVarSets, tyVarSetToList )
import Bag ( bagToList, foldrBag, isEmptyBag )
import Util ( isIn, zipEqual, zipWithEqual, zipWith3Equal, hasNoDups, assoc,
......@@ -232,7 +233,6 @@ tcBindWithSigs binder_names mbind tc_ty_sigs is_rec prag_info_fn
tcGetUniques no_of_binders `thenNF_Tc` \ uniqs ->
mapNF_Tc mk_mono_id_ty binder_names `thenNF_Tc` \ mono_id_tys ->
let
mono_id_tyvars = tyVarsOfTypes mono_id_tys
mono_ids = zipWith3Equal "tcBindAndSigs" mk_id binder_names uniqs mono_id_tys
mk_id name uniq ty = mkUserLocal (getOccName name) uniq ty (getSrcLoc name)
in
......@@ -248,21 +248,27 @@ tcBindWithSigs binder_names mbind tc_ty_sigs is_rec prag_info_fn
-- The tyvars_not_to_gen are free in the environment, and hence
-- candidates for generalisation, but sometimes the monomorphism
-- restriction means we can't generalise them nevertheless
getTyVarsToGen is_unrestricted mono_id_tyvars lie `thenTc` \ (tyvars_not_to_gen, tyvars_to_gen) ->
getTyVarsToGen is_unrestricted mono_id_tys lie `thenTc` \ (tyvars_not_to_gen, tyvars_to_gen) ->
-- DEAL WITH TYPE VARIABLE KINDS
mapTc defaultUncommittedTyVar (tyVarSetToList tyvars_to_gen) `thenTc` \ tyvars_to_gen_list ->
-- It's important that the final list (tyvars_to_gen_list) is fully
mapTc defaultUncommittedTyVar (tyVarSetToList tyvars_to_gen) `thenTc` \ real_tyvars_to_gen_list ->
let
real_tyvars_to_gen = mkTyVarSet real_tyvars_to_gen_list
-- It's important that the final list (real_tyvars_to_gen and real_tyvars_to_gen_list) is fully
-- zonked, *including boxity*, because they'll be included in the forall types of
-- the polymorphic Ids, and instances of these Ids will be generated from them.
--
-- Also NB that tcSimplify takes zonked tyvars as its arg, hence we pass
-- real_tyvars_to_gen
--
-- This step can do unification => keep other zonking after this
-- **** This step can do unification => keep other zonking after this ****
in
-- SIMPLIFY THE LIE
tcExtendGlobalTyVars tyvars_not_to_gen (
if null tc_ty_sigs then
-- No signatures, so just simplify the lie
tcSimplify tyvars_to_gen lie `thenTc` \ (lie_free, dict_binds, lie_bound) ->
tcSimplify real_tyvars_to_gen lie `thenTc` \ (lie_free, dict_binds, lie_bound) ->
returnTc (lie_free, dict_binds, map instToId (bagToList lie_bound))
else
......@@ -276,12 +282,12 @@ tcBindWithSigs binder_names mbind tc_ty_sigs is_rec prag_info_fn
-- Check that the needed dicts can be expressed in
-- terms of the signature ones
tcAddErrCtxt (sigsCtxt tysig_names) $
tcSimplifyAndCheck tyvars_to_gen dicts_sig lie `thenTc` \ (lie_free, dict_binds) ->
tcSimplifyAndCheck real_tyvars_to_gen dicts_sig lie `thenTc` \ (lie_free, dict_binds) ->
returnTc (lie_free, dict_binds, dict_ids)
) `thenTc` \ (lie_free, dict_binds, dicts_bound) ->
ASSERT( not (any (isUnboxedTypeKind . tyVarKind) tyvars_to_gen_list) )
ASSERT( not (any (isUnboxedTypeKind . tyVarKind) real_tyvars_to_gen_list) )
-- The instCantBeGeneralised stuff in tcSimplify should have
-- already raised an error if we're trying to generalise an unboxed tyvar
-- (NB: unboxed tyvars are always introduced along with a class constraint)
......@@ -295,13 +301,13 @@ tcBindWithSigs binder_names mbind tc_ty_sigs is_rec prag_info_fn
dict_tys = map tcIdType dicts_bound
mk_export binder_name mono_id zonked_mono_id_ty
| maybeToBool maybe_sig = (sig_tyvars, TcId sig_poly_id, TcId mono_id)
| otherwise = (tyvars_to_gen_list, TcId poly_id, TcId mono_id)
| maybeToBool maybe_sig = (sig_tyvars, TcId sig_poly_id, TcId mono_id)
| otherwise = (real_tyvars_to_gen_list, TcId poly_id, TcId mono_id)
where
maybe_sig = maybeSig tc_ty_sigs binder_name
Just (TySigInfo _ sig_poly_id sig_tyvars _ _ _) = maybe_sig
poly_id = mkUserId binder_name poly_ty (prag_info_fn binder_name)
poly_ty = mkForAllTys tyvars_to_gen_list $ mkFunTys dict_tys $ zonked_mono_id_ty
poly_ty = mkForAllTys real_tyvars_to_gen_list $ mkFunTys dict_tys $ zonked_mono_id_ty
-- It's important to build a fully-zonked poly_ty, because
-- we'll slurp out its free type variables when extending the
-- local environment (tcExtendLocalValEnv); if it's not zonked
......@@ -310,7 +316,7 @@ tcBindWithSigs binder_names mbind tc_ty_sigs is_rec prag_info_fn
-- BUILD RESULTS
returnTc (
AbsBinds tyvars_to_gen_list
AbsBinds real_tyvars_to_gen_list
dicts_bound
exports
(dict_binds `AndMonoBinds` mbind'),
......@@ -374,11 +380,11 @@ constrained tyvars. We don't use any of the results, except to
find which tyvars are constrained.
\begin{code}
getTyVarsToGen is_unrestricted mono_tyvars lie
getTyVarsToGen is_unrestricted mono_id_tys lie
= tcGetGlobalTyVars `thenNF_Tc` \ free_tyvars ->
zonkTcTyVars mono_tyvars `thenNF_Tc` \ mentioned_tyvars ->
mapNF_Tc zonkTcType mono_id_tys `thenNF_Tc` \ zonked_mono_id_tys ->
let
tyvars_to_gen = mentioned_tyvars `minusTyVarSet` free_tyvars
tyvars_to_gen = tyVarsOfTypes zonked_mono_id_tys `minusTyVarSet` free_tyvars
in
if is_unrestricted
then
......@@ -468,11 +474,13 @@ tcMonoBinds mbind binder_names mono_ids tc_ty_sigs
tc_mono_binds bind@(PatMonoBind pat grhss_and_binds locn)
= tcAddSrcLoc locn $
tcAddErrCtxt (patMonoBindsCtxt bind) $
tcPat pat `thenTc` \ (pat2, lie_pat, pat_ty) ->
-- Before checking the RHS, but after the pattern, extend the envt with
-- bindings for the *polymorphic* Ids from any type signatures
tcExtendLocalValEnv sig_names sig_ids $
tcGRHSsAndBinds grhss_and_binds `thenTc` \ (grhss_and_binds2, lie, grhss_ty) ->
tcAddErrCtxt (patMonoBindsCtxt bind) $
unifyTauTy pat_ty grhss_ty `thenTc_`
tcGRHSsAndBinds pat_ty grhss_and_binds `thenTc` \ (grhss_and_binds2, lie) ->
returnTc (PatMonoBind pat2 grhss_and_binds2 locn,
plusLIE lie_pat lie)
\end{code}
......
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