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,
import CoreSyn
import DsMonad
import DsUtils
-
+import Util ( takeList )
import Id
import SrcLoc
import Outputable
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
; 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
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
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
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
; 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