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,26 +640,29 @@ dataConUserType (MkData { dcUnivTyVars = univ_tvs,
mkFunTys arg_tys $
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
-- NB: these INCLUDE the existentially quantified arg 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
-- It's all post-flattening etc; this is a representation type
dataConInstArgTys dc@(MkData {dcRepArgTys = arg_tys,
dcUnivTyVars = univ_tvs,
dataConInstArgTys dc@(MkData {dcRepArgTys = rep_arg_tys,
dcUnivTyVars = univ_tvs, dcEqSpec = eq_spec,
dcExTyVars = ex_tvs}) inst_tys
= ASSERT2 ( length tyvars == length inst_tys
, ptext SLIT("dataConInstArgTys") <+> ppr dc $$ ppr tyvars $$ ppr inst_tys)
map (substTyWith tyvars inst_tys) arg_tys
where
tyvars = univ_tvs ++ ex_tvs
-- And the same deal for the original arg tys
dataConInstOrigArgTys :: DataCon -> [Type] -> [Type]
= ASSERT2 ( length univ_tvs == length inst_tys
, ptext SLIT("dataConInstArgTys") <+> ppr dc $$ ppr univ_tvs $$ ppr inst_tys)
ASSERT2 ( null ex_tvs && null eq_spec, ppr dc )
map (substTyWith univ_tvs inst_tys) rep_arg_tys
dataConInstOrigArgTys
:: DataCon -- Works for any DataCon
-> [Type] -- Includes existential tyvar args, but NOT
-- equality constraints or dicts
-> [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,
dcUnivTyVars = univ_tvs,
dcExTyVars = ex_tvs}) inst_tys
......
......@@ -20,7 +20,7 @@ import Type
import CoreSyn
import DsMonad
import DsUtils
import Util ( takeList )
import Id
import SrcLoc
import Outputable
......@@ -88,21 +88,23 @@ matchConFamily (var:vars) ty groups
matchOneCon vars ty (eqn1 : eqns) -- All eqns for a single constructor
= do { (wraps, eqns') <- mapAndUnzipM shift (eqn1:eqns)
; arg_vars <- selectMatchVars (take (dataConSourceArity con)
; arg_vars <- selectMatchVars (take (dataConSourceArity con1)
(eqn_pats (head eqns')))
-- Use the new arugment patterns as a source of
-- suggestions for the new variables
; 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) }
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
arg_tys = dataConInstOrigArgTys con inst_tys
n_co_args = length (dataConEqSpec con)
inst_tys = tcTyConAppArgs pat_ty1 ++ (drop n_co_args $ mkTyVarTys tvs1)
arg_tys = dataConInstOrigArgTys con1 inst_tys
inst_tys = tcTyConAppArgs pat_ty1 ++
mkTyVarTys (takeList (dataConExTyVars con1) tvs1)
-- 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,
pat_binds = bind, pat_args = args
......@@ -111,10 +113,12 @@ matchOneCon vars ty (eqn1 : eqns) -- All eqns for a single constructor
; return (wrapBinds (tvs `zip` tvs1)
. wrapBinds (ds `zip` dicts1)
. mkDsLet (Rec prs),
eqn { eqn_pats = conArgPats con arg_tys args ++ pats }) }
eqn { eqn_pats = conArgPats con1 arg_tys args ++ pats }) }
conArgPats :: DataCon
-> [Type] -- Instantiated argument types
-- Used only to fill in the types of WildPats, which
-- are probably never looked at anyway
-> HsConDetails Id (LPat Id)
-> [Pat Id]
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
matchSubTypes dc 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
-- assumes that newtypes are looked ^^^ through
| otherwise = dataConRepArgTys dc
......
......@@ -50,6 +50,9 @@ type LPat id = Located (Pat id)
data Pat id
= ------------ Simple patterns ---------------
WildPat PostTcType -- Wild card
-- The sole reason for a type on a WildPat is to
-- support hsPatType :: Pat Id -> Type
| VarPat id -- Variable
| VarPatOut id (DictBinds id) -- Used only for overloaded Ids; the
-- bindings give its overloaded instances
......
......@@ -148,6 +148,8 @@ mkNewTyConRhs tycon_name tycon con
rhs_ty = head (dataConInstOrigArgTys con (mkTyVarTys tvs))
-- Instantiate the data con with the
-- 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_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
; let ordinary_constraints
= [ mkClassPred cls [arg_ty]
| 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?
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