import Maybes
import Util
import FastString
-
-import Maybe
\end{code}
= pprTyConSort <+> pprHead
where
pprHead = pprTypeApp fam tys
- pprTyConSort | isDataTyCon tycon = ptext (sLit "data instance")
- | isNewTyCon tycon = ptext (sLit "newtype instance")
- | isSynTyCon tycon = ptext (sLit "type instance")
- | otherwise = panic "FamInstEnv.pprFamInstHdr"
+ pprTyConSort | isDataTyCon tycon = ptext (sLit "data instance")
+ | isNewTyCon tycon = ptext (sLit "newtype instance")
+ | isSynTyCon tycon = ptext (sLit "type instance")
+ | isAbstractTyCon tycon = ptext (sLit "data instance")
+ | otherwise = panic "FamInstEnv.pprFamInstHdr"
pprFamInsts :: [FamInst] -> SDoc
pprFamInsts finsts = vcat (map pprFamInst finsts)
-> [FamInstMatch] -- Successful matches
lookupFamInstEnv
- = lookup_fam_inst_env match
+ = lookup_fam_inst_env match True
where
match _ tpl_tvs tpl_tys tys = tcMatchTys tpl_tvs tpl_tys tys
-- unique supply to hand
lookupFamInstEnvConflicts envs fam_inst skol_tvs
- = lookup_fam_inst_env my_unify envs fam tys'
+ = lookup_fam_inst_env my_unify False envs fam tys'
where
inst_tycon = famInstTyCon fam_inst
(fam, tys) = expectJust "FamInstEnv.lookuFamInstEnvConflicts"
| otherwise = not (old_rhs `tcEqType` new_rhs)
where
old_tycon = famInstTyCon old_fam_inst
- old_rhs = mkTyConApp old_tycon (substTyVars subst (tyConTyVars old_tycon))
+ old_tvs = tyConTyVars old_tycon
+ old_rhs = mkTyConApp old_tycon (substTyVars subst old_tvs)
new_rhs = mkTyConApp inst_tycon (substTyVars subst skol_tvs)
\end{code}
While @lookupFamInstEnv@ uses a one-way match, the next function
-@lookupFamInstEnvUnify@ uses two-way matching (ie, unification). This is
+@lookupFamInstEnvConflicts@ uses two-way matching (ie, unification). This is
needed to check for overlapping instances.
For class instances, these two variants of lookup are combined into one
-> [Type] -- Target to match against
-> Maybe TvSubst
+type OneSidedMatch = Bool -- Are optimisations that are only valid for
+ -- one sided matches allowed?
+
lookup_fam_inst_env -- The worker, local to this module
:: MatchFun
+ -> OneSidedMatch
-> FamInstEnvs
-> TyCon -> [Type] -- What we are looking for
-> [FamInstMatch] -- Successful matches
-lookup_fam_inst_env match_fun (pkg_ie, home_ie) fam tys
- | not (isOpenTyCon fam)
+lookup_fam_inst_env match_fun one_sided (pkg_ie, home_ie) fam tys
+ | not (isFamilyTyCon fam)
= []
| otherwise
= ASSERT( n_tys >= arity ) -- Family type applications must be saturated
--------------
rough_tcs = roughMatchTcs match_tys
- all_tvs = all isNothing rough_tcs
+ all_tvs = all isNothing rough_tcs && one_sided
--------------
lookup env = case lookupUFM env fam of
| otherwise = rec_nts
go rec_nts (TyConApp tc tys) -- Expand open tycons
- | isOpenTyCon tc
+ | isFamilyTyCon tc
, (ACo co, ty) <- normaliseTcApp env tc tys
= -- The ACo says "something happened"
-- Note that normaliseType fully normalises, but it has do to so
= let -- First normalise the arg types so that they'll match
-- when we lookup in in the instance envt
(cois, ntys) = mapAndUnzip (normaliseType env) tys
- tycon_coi = mkTyConAppCoI tc ntys cois
+ tycon_coi = mkTyConAppCoI tc cois
in -- Now try the top-level redex
case lookupFamInstEnv env tc ntys of
-- A matching family instance exists
normaliseType env (AppTy ty1 ty2)
= let (coi1,nty1) = normaliseType env ty1
(coi2,nty2) = normaliseType env ty2
- in (mkAppTyCoI nty1 coi1 nty2 coi2, AppTy nty1 nty2)
+ in (mkAppTyCoI coi1 coi2, AppTy nty1 nty2)
normaliseType env (FunTy ty1 ty2)
= let (coi1,nty1) = normaliseType env ty1
(coi2,nty2) = normaliseType env ty2
- in (mkFunTyCoI nty1 coi1 nty2 coi2, FunTy nty1 nty2)
+ in (mkFunTyCoI coi1 coi2, FunTy nty1 nty2)
normaliseType env (ForAllTy tyvar ty1)
= let (coi,nty1) = normaliseType env ty1
- in (mkForAllTyCoI tyvar coi,ForAllTy tyvar nty1)
+ in (mkForAllTyCoI tyvar coi, ForAllTy tyvar nty1)
normaliseType _ ty@(TyVarTy _)
- = (IdCo,ty)
+ = (IdCo ty,ty)
normaliseType env (PredTy predty)
= normalisePred env predty
normalisePred :: FamInstEnvs -> PredType -> (CoercionI,Type)
normalisePred env (ClassP cls tys)
= let (cois,tys') = mapAndUnzip (normaliseType env) tys
- in (mkClassPPredCoI cls tys' cois, PredTy $ ClassP cls tys')
+ in (mkClassPPredCoI cls cois, PredTy $ ClassP cls tys')
normalisePred env (IParam ipn ty)
= let (coi,ty') = normaliseType env ty
in (mkIParamPredCoI ipn coi, PredTy $ IParam ipn ty')
normalisePred env (EqPred ty1 ty2)
= let (coi1,ty1') = normaliseType env ty1
(coi2,ty2') = normaliseType env ty2
- in (mkEqPredCoI ty1' coi1 ty2' coi2, PredTy $ EqPred ty1' ty2')
+ in (mkEqPredCoI coi1 coi2, PredTy $ EqPred ty1' ty2')
\end{code}