From 00b6d2567426ec52a113b1d3687e1d61368cafda Mon Sep 17 00:00:00 2001 From: Lemmih Date: Thu, 7 Jun 2007 21:38:37 +0000 Subject: [PATCH] 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 --- compiler/basicTypes/DataCon.lhs | 41 ++++++++++++++++++++----------------- compiler/deSugar/MatchCon.lhs | 20 ++++++++++-------- compiler/ghci/RtClosureInspect.hs | 2 +- compiler/hsSyn/HsPat.lhs | 3 +++ compiler/iface/BuildTyCl.lhs | 2 ++ compiler/typecheck/TcDeriv.lhs | 3 ++- 6 files changed, 42 insertions(+), 29 deletions(-) diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs index 550be30..9ce966e 100644 --- a/compiler/basicTypes/DataCon.lhs +++ b/compiler/basicTypes/DataCon.lhs @@ -640,34 +640,37 @@ 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 - = ASSERT2( length tyvars == length inst_tys + = ASSERT2( length tyvars == length inst_tys , ptext SLIT("dataConInstOrigArgTys") <+> ppr dc $$ ppr tyvars $$ ppr inst_tys ) - map (substTyWith tyvars inst_tys) arg_tys - where - tyvars = univ_tvs ++ ex_tvs + map (substTyWith tyvars inst_tys) arg_tys + where + tyvars = univ_tvs ++ ex_tvs \end{code} These two functions get the real argument types of the constructor, diff --git a/compiler/deSugar/MatchCon.lhs b/compiler/deSugar/MatchCon.lhs index 5233d59..3f25fc7 100644 --- a/compiler/deSugar/MatchCon.lhs +++ b/compiler/deSugar/MatchCon.lhs @@ -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 diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs index 7294894..b28981d 100644 --- a/compiler/ghci/RtClosureInspect.hs +++ b/compiler/ghci/RtClosureInspect.hs @@ -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 diff --git a/compiler/hsSyn/HsPat.lhs b/compiler/hsSyn/HsPat.lhs index abfb3c6..e434779 100644 --- a/compiler/hsSyn/HsPat.lhs +++ b/compiler/hsSyn/HsPat.lhs @@ -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 diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs index 333d808..9f35453 100644 --- a/compiler/iface/BuildTyCl.lhs +++ b/compiler/iface/BuildTyCl.lhs @@ -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 diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index b973ec4..e26c97d 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -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 -- 1.7.10.4