Commit 00b6d256 authored by David Himmelstrup's avatar David Himmelstrup

Fix a bug in MatchCon, and clarify what dataConInstOrigArgTys does

There was an outright bug in MatchCon.matchOneCon, in the construction
of arg_tys.  Easily fixed.  It never showed up becuase the arg_tys are
only used in WildPats, and they in turn seldom have their types looked
(except by hsPatType).  So I can't make a test case for htis.

While I was investigating, I added a bit of clarifation and
invariant-checking to dataConInstOrigArgTys and dataConInstArgTys
parent 481b014b
...@@ -640,34 +640,37 @@ dataConUserType (MkData { dcUnivTyVars = univ_tvs, ...@@ -640,34 +640,37 @@ dataConUserType (MkData { dcUnivTyVars = univ_tvs,
mkFunTys arg_tys $ mkFunTys arg_tys $
res_ty res_ty
dataConInstArgTys :: DataCon dataConInstArgTys :: DataCon -- A datacon with no existentials or equality constraints
-- However, it can have a dcTheta (notably it can be a
-- class dictionary, with superclasses)
-> [Type] -- Instantiated at these types -> [Type] -- Instantiated at these types
-- NB: these INCLUDE the existentially quantified arg types
-> [Type] -- Needs arguments of these types -> [Type] -- Needs arguments of these types
-- NB: these INCLUDE the existentially quantified dict args -- NB: these INCLUDE any dict args
-- but EXCLUDE the data-decl context which is discarded -- but EXCLUDE the data-decl context which is discarded
-- It's all post-flattening etc; this is a representation type -- It's all post-flattening etc; this is a representation type
dataConInstArgTys dc@(MkData {dcRepArgTys = arg_tys, dataConInstArgTys dc@(MkData {dcRepArgTys = rep_arg_tys,
dcUnivTyVars = univ_tvs, dcUnivTyVars = univ_tvs, dcEqSpec = eq_spec,
dcExTyVars = ex_tvs}) inst_tys dcExTyVars = ex_tvs}) inst_tys
= ASSERT2 ( length tyvars == length inst_tys = ASSERT2 ( length univ_tvs == length inst_tys
, ptext SLIT("dataConInstArgTys") <+> ppr dc $$ ppr tyvars $$ ppr inst_tys) , ptext SLIT("dataConInstArgTys") <+> ppr dc $$ ppr univ_tvs $$ ppr inst_tys)
ASSERT2 ( null ex_tvs && null eq_spec, ppr dc )
map (substTyWith tyvars inst_tys) arg_tys map (substTyWith univ_tvs inst_tys) rep_arg_tys
where
tyvars = univ_tvs ++ ex_tvs dataConInstOrigArgTys
:: DataCon -- Works for any DataCon
-> [Type] -- Includes existential tyvar args, but NOT
-- And the same deal for the original arg tys -- equality constraints or dicts
dataConInstOrigArgTys :: DataCon -> [Type] -> [Type] -> [Type] -- Returns just the instsantiated *value* arguments
-- For vanilla datacons, it's all quite straightforward
-- But for the call in MatchCon, we really do want just the value args
dataConInstOrigArgTys dc@(MkData {dcOrigArgTys = arg_tys, dataConInstOrigArgTys dc@(MkData {dcOrigArgTys = arg_tys,
dcUnivTyVars = univ_tvs, dcUnivTyVars = univ_tvs,
dcExTyVars = ex_tvs}) inst_tys dcExTyVars = ex_tvs}) inst_tys
= ASSERT2( length tyvars == length inst_tys = ASSERT2( length tyvars == length inst_tys
, ptext SLIT("dataConInstOrigArgTys") <+> ppr dc $$ ppr tyvars $$ ppr inst_tys ) , ptext SLIT("dataConInstOrigArgTys") <+> ppr dc $$ ppr tyvars $$ ppr inst_tys )
map (substTyWith tyvars inst_tys) arg_tys map (substTyWith tyvars inst_tys) arg_tys
where where
tyvars = univ_tvs ++ ex_tvs tyvars = univ_tvs ++ ex_tvs
\end{code} \end{code}
These two functions get the real argument types of the constructor, These two functions get the real argument types of the constructor,
......
...@@ -20,7 +20,7 @@ import Type ...@@ -20,7 +20,7 @@ import Type
import CoreSyn import CoreSyn
import DsMonad import DsMonad
import DsUtils import DsUtils
import Util ( takeList )
import Id import Id
import SrcLoc import SrcLoc
import Outputable import Outputable
...@@ -88,21 +88,23 @@ matchConFamily (var:vars) ty groups ...@@ -88,21 +88,23 @@ matchConFamily (var:vars) ty groups
matchOneCon vars ty (eqn1 : eqns) -- All eqns for a single constructor matchOneCon vars ty (eqn1 : eqns) -- All eqns for a single constructor
= do { (wraps, eqns') <- mapAndUnzipM shift (eqn1:eqns) = do { (wraps, eqns') <- mapAndUnzipM shift (eqn1:eqns)
; arg_vars <- selectMatchVars (take (dataConSourceArity con) ; arg_vars <- selectMatchVars (take (dataConSourceArity con1)
(eqn_pats (head eqns'))) (eqn_pats (head eqns')))
-- Use the new arugment patterns as a source of -- Use the new arugment patterns as a source of
-- suggestions for the new variables -- suggestions for the new variables
; match_result <- match (arg_vars ++ vars) ty eqns' ; match_result <- match (arg_vars ++ vars) ty eqns'
; return (con, tvs1 ++ dicts1 ++ arg_vars, ; return (con1, tvs1 ++ dicts1 ++ arg_vars,
adjustMatchResult (foldr1 (.) wraps) match_result) } adjustMatchResult (foldr1 (.) wraps) match_result) }
where where
ConPatOut { pat_con = L _ con, pat_ty = pat_ty1, ConPatOut { pat_con = L _ con1, pat_ty = pat_ty1,
pat_tvs = tvs1, pat_dicts = dicts1 } = firstPat eqn1 pat_tvs = tvs1, pat_dicts = dicts1 } = firstPat eqn1
arg_tys = dataConInstOrigArgTys con inst_tys arg_tys = dataConInstOrigArgTys con1 inst_tys
n_co_args = length (dataConEqSpec con) inst_tys = tcTyConAppArgs pat_ty1 ++
inst_tys = tcTyConAppArgs pat_ty1 ++ (drop n_co_args $ mkTyVarTys tvs1) mkTyVarTys (takeList (dataConExTyVars con1) tvs1)
-- Newtypes opaque, hence tcTyConAppArgs -- Newtypes opaque, hence tcTyConAppArgs
-- dataConInstOrigArgTys takes the univ and existential tyvars
-- and returns the types of the *value* args, which is what we want
shift eqn@(EqnInfo { eqn_pats = ConPatOut{ pat_tvs = tvs, pat_dicts = ds, shift eqn@(EqnInfo { eqn_pats = ConPatOut{ pat_tvs = tvs, pat_dicts = ds,
pat_binds = bind, pat_args = args pat_binds = bind, pat_args = args
...@@ -111,10 +113,12 @@ matchOneCon vars ty (eqn1 : eqns) -- All eqns for a single constructor ...@@ -111,10 +113,12 @@ matchOneCon vars ty (eqn1 : eqns) -- All eqns for a single constructor
; return (wrapBinds (tvs `zip` tvs1) ; return (wrapBinds (tvs `zip` tvs1)
. wrapBinds (ds `zip` dicts1) . wrapBinds (ds `zip` dicts1)
. mkDsLet (Rec prs), . mkDsLet (Rec prs),
eqn { eqn_pats = conArgPats con arg_tys args ++ pats }) } eqn { eqn_pats = conArgPats con1 arg_tys args ++ pats }) }
conArgPats :: DataCon conArgPats :: DataCon
-> [Type] -- Instantiated argument types -> [Type] -- Instantiated argument types
-- Used only to fill in the types of WildPats, which
-- are probably never looked at anyway
-> HsConDetails Id (LPat Id) -> HsConDetails Id (LPat Id)
-> [Pat Id] -> [Pat Id]
conArgPats data_con arg_tys (PrefixCon ps) = map unLoc ps conArgPats data_con arg_tys (PrefixCon ps) = map unLoc ps
......
...@@ -518,7 +518,7 @@ cvObtainTerm hsc_env force mb_ty hval = runTR hsc_env $ do ...@@ -518,7 +518,7 @@ cvObtainTerm hsc_env force mb_ty hval = runTR hsc_env $ do
matchSubTypes dc ty matchSubTypes dc ty
| Just (_,ty_args) <- splitTyConApp_maybe (repType ty) | Just (_,ty_args) <- splitTyConApp_maybe (repType ty)
, null (dataConExTyVars dc) --TODO case of extra existential tyvars , isVanillaDataCon dc --TODO non-vanilla case
= dataConInstArgTys dc ty_args = dataConInstArgTys dc ty_args
-- assumes that newtypes are looked ^^^ through -- assumes that newtypes are looked ^^^ through
| otherwise = dataConRepArgTys dc | otherwise = dataConRepArgTys dc
......
...@@ -50,6 +50,9 @@ type LPat id = Located (Pat id) ...@@ -50,6 +50,9 @@ type LPat id = Located (Pat id)
data Pat id data Pat id
= ------------ Simple patterns --------------- = ------------ Simple patterns ---------------
WildPat PostTcType -- Wild card WildPat PostTcType -- Wild card
-- The sole reason for a type on a WildPat is to
-- support hsPatType :: Pat Id -> Type
| VarPat id -- Variable | VarPat id -- Variable
| VarPatOut id (DictBinds id) -- Used only for overloaded Ids; the | VarPatOut id (DictBinds id) -- Used only for overloaded Ids; the
-- bindings give its overloaded instances -- bindings give its overloaded instances
......
...@@ -148,6 +148,8 @@ mkNewTyConRhs tycon_name tycon con ...@@ -148,6 +148,8 @@ mkNewTyConRhs tycon_name tycon con
rhs_ty = head (dataConInstOrigArgTys con (mkTyVarTys tvs)) rhs_ty = head (dataConInstOrigArgTys con (mkTyVarTys tvs))
-- Instantiate the data con with the -- Instantiate the data con with the
-- type variables from the tycon -- type variables from the tycon
-- NB: a newtype DataCon has no existentials; hence the
-- call to dataConInstOrigArgTys has the right type args
etad_tvs :: [TyVar] -- Matched lazily, so that mkNewTypeCoercion can etad_tvs :: [TyVar] -- Matched lazily, so that mkNewTypeCoercion can
etad_rhs :: Type -- return a TyCon without pulling on rhs_ty etad_rhs :: Type -- return a TyCon without pulling on rhs_ty
......
...@@ -479,7 +479,8 @@ mk_data_eqn loc orig tvs cls tycon tc_args rep_tc rep_tc_args ...@@ -479,7 +479,8 @@ mk_data_eqn loc orig tvs cls tycon tc_args rep_tc rep_tc_args
; let ordinary_constraints ; let ordinary_constraints
= [ mkClassPred cls [arg_ty] = [ mkClassPred cls [arg_ty]
| data_con <- tyConDataCons rep_tc, | data_con <- tyConDataCons rep_tc,
arg_ty <- dataConInstOrigArgTys data_con rep_tc_args, arg_ty <- ASSERT( isVanillaDataCon data_con )
dataConInstOrigArgTys data_con rep_tc_args,
not (isUnLiftedType arg_ty) ] -- No constraints for unlifted types? not (isUnLiftedType arg_ty) ] -- No constraints for unlifted types?
tiresome_subst = zipTopTvSubst (tyConTyVars rep_tc) rep_tc_args tiresome_subst = zipTopTvSubst (tyConTyVars rep_tc) rep_tc_args
......
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