From 4899cc823373bd016a49cdb0dffd0e22150ec07e Mon Sep 17 00:00:00 2001 From: Manuel M T Chakravarty Date: Mon, 14 May 2007 06:52:34 +0000 Subject: [PATCH] Revised signature of tcLookupFamInst and lookupFamInstEnv - This changes the signature of FamInstEnv.lookupFamInstEnv and FamInstEnv.lookupFamInstEnvUnify in a manner similar to SPJ's previous patch for InstEnv.llokupInstEnv - tcLookupFamInst now permits the lookup of instances that are more general than the type instance requested. --- compiler/simplCore/LiberateCase.lhs | 3 +-- compiler/typecheck/FamInst.lhs | 2 +- compiler/typecheck/TcDeriv.lhs | 27 +++++++++++++++++++++++-- compiler/typecheck/TcEnv.lhs | 37 ++++++++++++++++++++--------------- compiler/types/FamInstEnv.lhs | 24 +++++++++++++++++++---- 5 files changed, 68 insertions(+), 25 deletions(-) diff --git a/compiler/simplCore/LiberateCase.lhs b/compiler/simplCore/LiberateCase.lhs index a7b613d..9f03adf 100644 --- a/compiler/simplCore/LiberateCase.lhs +++ b/compiler/simplCore/LiberateCase.lhs @@ -274,10 +274,9 @@ mkCase :: LibCaseEnv -> CoreExpr -> Id -> Type -> [CoreAlt] -> CoreExpr -- See Note [Indexed data types] mkCase env scrut bndr ty [(DEFAULT,_,rhs)] | Just (tycon, tys) <- splitTyConApp_maybe (idType bndr) - , [(subst, fam_inst)] <- lookupFamInstEnv (lc_fams env) tycon tys + , [(fam_inst, rep_tys)] <- lookupFamInstEnv (lc_fams env) tycon tys = let rep_tc = famInstTyCon fam_inst - rep_tys = map (substTyVar subst) (tyConTyVars rep_tc) bndr' = setIdType bndr (mkTyConApp rep_tc rep_tys) Just co_tc = tyConFamilyCoercion_maybe rep_tc co = mkTyConApp co_tc rep_tys diff --git a/compiler/typecheck/FamInst.lhs b/compiler/typecheck/FamInst.lhs index fd98fe9..f85f6b9 100644 --- a/compiler/typecheck/FamInst.lhs +++ b/compiler/typecheck/FamInst.lhs @@ -180,7 +180,7 @@ checkForConflicts inst_envs famInst ; let { matches = lookupFamInstEnvUnify inst_envs fam tys' ; conflicts = [ conflictingFamInst - | match@(_, conflictingFamInst) <- matches + | match@(conflictingFamInst, _) <- matches , conflicting fam tys' tycon match ] } diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 1a9a881..4e1a065 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -47,6 +47,8 @@ import Util import ListSetOps import Outputable import Bag + +import Monad (unless) \end{code} %************************************************************************ @@ -395,7 +397,7 @@ mkEqnHelp orig tvs cls cls_tys tc_app full_tc_args = tc_args ++ mkTyVarTys extra_tvs full_tvs = tvs ++ extra_tvs - ; (rep_tc, rep_tc_args) <- tcLookupFamInst tycon full_tc_args + ; (rep_tc, rep_tc_args) <- tcLookupFamInstExact tycon full_tc_args ; gla_exts <- doptM Opt_GlasgowExts ; overlap_flag <- getOverlapFlag @@ -415,6 +417,27 @@ mkEqnHelp orig tvs cls cls_tys tc_app baleOut err = addErrTc err >> returnM (Nothing, Nothing) \end{code} +Auxiliary lookup wrapper which requires that looked up family instances are +not type instances. + +\begin{code} +tcLookupFamInstExact :: TyCon -> [Type] -> TcM (TyCon, [Type]) +tcLookupFamInstExact tycon tys + = do { result@(rep_tycon, rep_tys) <- tcLookupFamInst tycon tys + ; let { tvs = map (Type.getTyVar + "TcDeriv.tcLookupFamInstExact") + tys + ; variable_only_subst = all Type.isTyVarTy rep_tys && + sizeVarSet (mkVarSet tvs) == length tvs + -- renaming may have no repetitions + } + ; unless variable_only_subst $ + famInstNotFound tycon tys [result] + ; return result + } + +\end{code} + %************************************************************************ %* * @@ -980,7 +1003,7 @@ genInst spec -- In case of a family instance, we need to use the representation -- tycon (after all, it has the data constructors) - ; (tycon, _) <- tcLookupFamInst visible_tycon tyArgs + ; (tycon, _) <- tcLookupFamInstExact visible_tycon tyArgs ; let (meth_binds, aux_binds) = genDerivBinds clas fix_env tycon -- Bring the right type variables into diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index 787616a..0f9bf23 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -42,7 +42,10 @@ module TcEnv( topIdLvl, -- New Ids - newLocalName, newDFunName, newFamInstTyConName + newLocalName, newDFunName, newFamInstTyConName, + + -- Errors + famInstNotFound ) where #include "HsVersions.h" @@ -159,7 +162,21 @@ tcLookupLocatedTyCon :: Located Name -> TcM TyCon tcLookupLocatedTyCon = addLocM tcLookupTyCon -- Look up the representation tycon of a family instance. --- Return the rep tycon and the corresponding rep args +-- +-- The match must be unique - ie, match exactly one instance - but the +-- type arguments used for matching may be more specific than those of +-- the family instance declaration. +-- +-- Return the instance tycon and its type instance. For example, if we have +-- +-- tcLookupFamInst 'T' '[Int]' yields (':R42T', 'Int') +-- +-- then we have a coercion (ie, type instance of family instance coercion) +-- +-- :Co:R42T Int :: T [Int] ~ :R42T Int +-- +-- which implies that :R42T was declared as 'data instance T [a]'. +-- tcLookupFamInst :: TyCon -> [Type] -> TcM (TyCon, [Type]) tcLookupFamInst tycon tys | not (isOpenTyCon tycon) @@ -169,20 +186,8 @@ tcLookupFamInst tycon tys ; eps <- getEps ; let instEnv = (eps_fam_inst_env eps, tcg_fam_inst_env env) ; case lookupFamInstEnv instEnv tycon tys of - - [(subst, fam_inst)] | variable_only_subst -> - return (rep_tc, substTyVars subst (tyConTyVars rep_tc)) - where -- NB: assumption is that (tyConTyVars rep_tc) is in - -- the domain of the substitution - rep_tc = famInstTyCon fam_inst - subst_domain = varEnvElts . getTvSubstEnv $ subst - tvs = map (Type.getTyVar "tcLookupFamInst") - subst_domain - variable_only_subst = all Type.isTyVarTy subst_domain && - sizeVarSet (mkVarSet tvs) == length tvs - -- renaming may have no repetitions - - other -> famInstNotFound tycon tys other + [(fam_inst, rep_tys)] -> return (famInstTyCon fam_inst, rep_tys) + other -> famInstNotFound tycon tys other } \end{code} diff --git a/compiler/types/FamInstEnv.lhs b/compiler/types/FamInstEnv.lhs index 481c680..b8c82f8 100644 --- a/compiler/types/FamInstEnv.lhs +++ b/compiler/types/FamInstEnv.lhs @@ -198,10 +198,24 @@ Multiple matches are only possible in case of type families (not data families), and then, it doesn't matter which match we choose (as the instances are guaranteed confluent). +We return the matching family instances and the type instance at which it +matches. For example, if we lookup 'T [Int]' and have a family instance + + data instance T [a] = .. + +desugared to + + data :R42T a = .. + coe :Co:R42T a :: T [a] ~ :R42T a + +we return the matching instance '(FamInst{.., fi_tycon = :R42T}, Int)'. + \begin{code} +type FamInstMatch = (FamInst, [Type]) -- Matching type instance + lookupFamInstEnv :: FamInstEnvs -> TyCon -> [Type] -- What we are looking for - -> [(TvSubst, FamInst)] -- Successful matches + -> [FamInstMatch] -- Successful matches lookupFamInstEnv (pkg_ie, home_ie) fam tys = home_matches ++ pkg_matches where @@ -231,7 +245,7 @@ lookupFamInstEnv (pkg_ie, home_ie) fam tys -- Proper check | Just subst <- tcMatchTys tpl_tvs tpl_tys tys - = (subst, item) : find rest + = (item, substTyVars subst (tyConTyVars tycon)) : find rest -- No match => try next | otherwise @@ -250,7 +264,7 @@ indexed synonyms and we don't want to slow that down by needless unification. \begin{code} lookupFamInstEnvUnify :: (FamInstEnv, FamInstEnv) -> TyCon -> [Type] - -> [(TvSubst, FamInst)] + -> [(FamInstMatch)] lookupFamInstEnvUnify (pkg_ie, home_ie) fam tys = home_matches ++ pkg_matches where @@ -286,7 +300,9 @@ lookupFamInstEnvUnify (pkg_ie, home_ie) fam tys -- Unification will break badly if the variables overlap -- They shouldn't because we allocate separate uniques for them case tcUnifyTys bind_fn tpl_tys tys of - Just subst -> (subst, item) : find rest + Just subst -> let rep_tys = substTyVars subst (tyConTyVars tycon) + in + (item, rep_tys) : find rest Nothing -> find rest -- See explanation at @InstEnv.bind_fn@. -- 1.7.10.4