-- 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
; let { matches = lookupFamInstEnvUnify inst_envs fam tys'
; conflicts = [ conflictingFamInst
- | match@(_, conflictingFamInst) <- matches
+ | match@(conflictingFamInst, _) <- matches
, conflicting fam tys' tycon match
]
}
import ListSetOps
import Outputable
import Bag
+
+import Monad (unless)
\end{code}
%************************************************************************
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
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}
+
%************************************************************************
%* *
-- 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
topIdLvl,
-- New Ids
- newLocalName, newDFunName, newFamInstTyConName
+ newLocalName, newDFunName, newFamInstTyConName,
+
+ -- Errors
+ famInstNotFound
) where
#include "HsVersions.h"
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)
; 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}
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
-- 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
\begin{code}
lookupFamInstEnvUnify :: (FamInstEnv, FamInstEnv) -> TyCon -> [Type]
- -> [(TvSubst, FamInst)]
+ -> [(FamInstMatch)]
lookupFamInstEnvUnify (pkg_ie, home_ie) fam tys
= home_matches ++ pkg_matches
where
-- 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@.
projects / ghc-hetmet.git / commitdiff