Commit f2f40c0f authored by simonpj's avatar simonpj
Browse files

[project @ 2002-04-03 09:45:14 by simonpj]

-----------------------------
	Put existential tyvars second
	[fixes ParsecPerm lint error]
	-----------------------------

In an existential data constr:

	data Eq a => T a = forall b. Ord b => MkT a [b]

the type of MkT is

	MkT :: forall a b . Ord b => a -> [b] -> MkT a

Note that the existential tyvars (b in this case) come *after*
the "ordinary" tyvars.

I had switched this around earlier in the week, but I'm putting
it back (and fixing a bug) because I found it really works better second.

Reason: in a case expression we may find:
	case (e :: T t) of { MkT b (d:Ord b) (x:t) (xs:[b]) -> ... }
It's convenient to apply the rep-type of MkT to 't', to get
	forall b. Ord b => ...
and use that to check the pattern.  Mind you, this is really only
use in CoreLint.
parent 94c5c5a2
......@@ -118,13 +118,18 @@ data DataCon
-- data Eq a => T a = forall b. Ord b => MkT a [b]
dcRepType :: Type, -- Type of the constructor
-- forall b a . Ord b => a -> [b] -> MkT a
-- forall a b . Ord b => a -> [b] -> MkT a
-- (this is *not* of the constructor wrapper Id:
-- see notes after this data type declaration)
--
-- Notice that the existential type parameters come
-- *first*. It doesn't really matter provided we are
-- consistent.
-- Notice that the existential type parameters come *second*.
-- Reason: in a case expression we may find:
-- case (e :: T t) of { MkT b (d:Ord b) (x:t) (xs:[b]) -> ... }
-- It's convenient to apply the rep-type of MkT to 't', to get
-- forall b. Ord b => ...
-- and use that to check the pattern. Mind you, this is really only
-- use in CoreLint.
-- The next six fields express the type of the constructor, in pieces
-- e.g.
......@@ -295,7 +300,7 @@ mkDataCon name arg_stricts fields
(rep_arg_stricts, rep_arg_tys) = computeRep real_stricts real_arg_tys
tag = assoc "mkDataCon" (tyConDataCons tycon `zip` [fIRST_TAG..]) con
ty = mkForAllTys (ex_tyvars ++ tyvars)
ty = mkForAllTys (tyvars ++ ex_tyvars)
(mkFunTys rep_arg_tys result_ty)
-- NB: the existential dict args are already in rep_arg_tys
......@@ -371,7 +376,7 @@ dataConArgTys :: DataCon
dataConArgTys (MkData {dcRepArgTys = arg_tys, dcTyVars = tyvars,
dcExTyVars = ex_tyvars}) inst_tys
= map (substTyWith (ex_tyvars ++ tyvars) inst_tys) arg_tys
= map (substTyWith (tyvars ++ ex_tyvars) inst_tys) arg_tys
dataConTheta :: DataCon -> ThetaType
dataConTheta dc = dcStupidTheta dc
......@@ -384,7 +389,7 @@ dataConExistentialTyVars dc = dcExTyVars dc
dataConInstOrigArgTys :: DataCon -> [Type] -> [Type]
dataConInstOrigArgTys (MkData {dcOrigArgTys = arg_tys, dcTyVars = tyvars,
dcExTyVars = ex_tyvars}) inst_tys
= map (substTyWith (ex_tyvars ++ tyvars) inst_tys) arg_tys
= map (substTyWith (tyvars ++ ex_tyvars) inst_tys) arg_tys
\end{code}
These two functions get the real argument types of the constructor,
......
......@@ -299,7 +299,7 @@ mkDataConWrapId data_con
(map varToCoreExpr (all_tyvars ++ reverse rep_ids))
(tyvars, _, ex_tyvars, ex_theta, orig_arg_tys, tycon) = dataConSig data_con
all_tyvars = ex_tyvars ++ tyvars
all_tyvars = tyvars ++ ex_tyvars
ex_dict_tys = mkPredTys ex_theta
all_arg_tys = ex_dict_tys ++ orig_arg_tys
......
......@@ -436,6 +436,7 @@ lintCoreAlt scrut_ty alt@(DataAlt con, args, rhs)
-- Scrutinee type must be a tycon applicn; checked by caller
-- This code is remarkably compact considering what it does!
-- NB: args must be in scope here so that the lintCoreArgs line works.
-- NB: relies on existential type args coming *after* ordinary type args
case splitTyConApp scrut_ty of { (tycon, tycon_arg_tys) ->
lintTyApps (dataConRepType con) tycon_arg_tys `thenL` \ con_type ->
lintCoreArgs con_type (map mk_arg args) `thenL` \ con_result_ty ->
......
......@@ -372,15 +372,15 @@ tcInstDataCon orig data_con
-- We generate constraints for the stupid theta even when
-- pattern matching (as the Report requires)
in
tcInstTyVars VanillaTv (ex_tvs ++ tvs) `thenNF_Tc` \ (all_tvs', ty_args', tenv) ->
tcInstTyVars VanillaTv (tvs ++ ex_tvs) `thenNF_Tc` \ (all_tvs', ty_args', tenv) ->
let
stupid_theta' = substTheta tenv stupid_theta
ex_theta' = substTheta tenv ex_theta
arg_tys' = map (substTy tenv) arg_tys
n_ex_tvs = length ex_tvs
ex_tvs' = take n_ex_tvs all_tvs'
result_ty = mkTyConApp tycon (drop n_ex_tvs ty_args')
n_normal_tvs = length tvs
ex_tvs' = drop n_normal_tvs all_tvs'
result_ty = mkTyConApp tycon (take n_normal_tvs ty_args')
in
newDicts orig stupid_theta' `thenNF_Tc` \ stupid_dicts ->
newDicts orig ex_theta' `thenNF_Tc` \ ex_dicts ->
......
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