projects
/
ghc-hetmet.git
/ commitdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
| commitdiff |
tree
raw
|
patch
|
inline
| side by side (parent:
aef1dc9
)
[project @ 1997-07-26 02:13:00 by sof]
author
sof
<unknown>
Sat, 26 Jul 1997 02:13:00 +0000
(
02:13
+0000)
committer
sof
<unknown>
Sat, 26 Jul 1997 02:13:00 +0000
(
02:13
+0000)
bug fixes
ghc/compiler/typecheck/TcBinds.lhs
patch
|
blob
|
history
diff --git
a/ghc/compiler/typecheck/TcBinds.lhs
b/ghc/compiler/typecheck/TcBinds.lhs
index
f369695
..
2417160
100644
(file)
--- a/
ghc/compiler/typecheck/TcBinds.lhs
+++ b/
ghc/compiler/typecheck/TcBinds.lhs
@@
-24,7
+24,7
@@
import RnHsSyn ( SYN_IE(RenamedHsBinds), RenamedSig(..),
SYN_IE(RenamedMonoBinds)
)
import TcHsSyn ( SYN_IE(TcHsBinds), SYN_IE(TcMonoBinds),
SYN_IE(RenamedMonoBinds)
)
import TcHsSyn ( SYN_IE(TcHsBinds), SYN_IE(TcMonoBinds),
- TcIdOcc(..), SYN_IE(TcIdBndr), SYN_IE(TcExpr),
+ SYN_IE(TcExpr),
tcIdType
)
tcIdType
)
@@
-41,7
+41,8
@@
import TcSimplify ( tcSimplify, tcSimplifyAndCheck )
import TcMonoType ( tcHsType )
import TcPat ( tcPat )
import TcSimplify ( bindInstsOfLocalFuns )
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
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 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,
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
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
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
-- 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
-- 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.
-- 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
-- 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
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) $
-- 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) ->
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)
-- 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
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)
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
-- 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 (
-- BUILD RESULTS
returnTc (
- AbsBinds tyvars_to_gen_list
+ AbsBinds real_tyvars_to_gen_list
dicts_bound
exports
(dict_binds `AndMonoBinds` mbind'),
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}
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 ->
= 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
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
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 $
tc_mono_binds bind@(PatMonoBind pat grhss_and_binds locn)
= tcAddSrcLoc locn $
+ tcAddErrCtxt (patMonoBindsCtxt bind) $
tcPat pat `thenTc` \ (pat2, lie_pat, pat_ty) ->
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 $
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}
returnTc (PatMonoBind pat2 grhss_and_binds2 locn,
plusLIE lie_pat lie)
\end{code}