+
+-- Dictionaries
+lookupInst dict@(Dict _ pred@(ClassP clas tys) loc)
+ | all tcIsTyVarTy tys -- Common special case; no lookup
+ -- NB: tcIsTyVarTy... don't look through newtypes!
+ = returnM NoInstance
+
+ | otherwise
+ = do { pkg_ie <- loadImportedInsts clas tys
+ -- Suck in any instance decls that may be relevant
+ ; tcg_env <- getGblEnv
+ ; dflags <- getDOpts
+ ; case lookupInstEnv dflags (pkg_ie, tcg_inst_env tcg_env) clas tys of {
+ ([(tenv, (_,_,dfun_id))], []) -> instantiate_dfun tenv dfun_id pred loc ;
+ (matches, unifs) -> do
+ { traceTc (text "lookupInst" <+> vcat [text "matches" <+> ppr matches,
+ text "unifs" <+> ppr unifs])
+ ; return NoInstance } } }
+ -- In the case of overlap (multiple matches) we report
+ -- NoInstance here. That has the effect of making the
+ -- context-simplifier return the dict as an irreducible one.
+ -- Then it'll be given to addNoInstanceErrs, which will do another
+ -- lookupInstEnv to get the detailed info about what went wrong.
+
+lookupInst (Dict _ _ _) = returnM NoInstance
+
+-----------------
+instantiate_dfun tenv dfun_id pred loc
+ = -- Record that this dfun is needed
+ record_dfun_usage dfun_id `thenM_`
+
+ -- It's possible that not all the tyvars are in
+ -- the substitution, tenv. For example:
+ -- instance C X a => D X where ...
+ -- (presumably there's a functional dependency in class C)
+ -- Hence the mk_ty_arg to instantiate any un-substituted tyvars.
+ getStage `thenM` \ use_stage ->
+ checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
+ (topIdLvl dfun_id) use_stage `thenM_`
+ let
+ (tyvars, rho) = tcSplitForAllTys (idType dfun_id)
+ mk_ty_arg tv = case lookupSubstEnv tenv tv of
+ Just (DoneTy ty) -> returnM ty
+ Nothing -> tcInstTyVar VanillaTv tv `thenM` \ tc_tv ->
+ returnM (mkTyVarTy tc_tv)
+ in
+ mappM mk_ty_arg tyvars `thenM` \ ty_args ->
+ let
+ dfun_rho = substTy (mkTyVarSubst tyvars ty_args) rho
+ (theta, _) = tcSplitPhiTy dfun_rho
+ ty_app = mkHsTyApp (HsVar dfun_id) ty_args
+ in
+ if null theta then
+ returnM (SimpleInst ty_app)
+ else
+ newDictsAtLoc loc theta `thenM` \ dicts ->
+ let
+ rhs = mkHsDictApp ty_app (map instToId dicts)
+ in
+ returnM (GenInst dicts rhs)
+
+record_dfun_usage dfun_id
+ | isInternalName dfun_name = return () -- From this module
+ | not (isHomePackageName dfun_name) = return () -- From another package package
+ | otherwise = getGblEnv `thenM` \ tcg_env ->
+ updMutVar (tcg_inst_uses tcg_env)
+ (`addOneToNameSet` idName dfun_id)
+ where
+ dfun_name = idName dfun_id
+
+tcGetInstEnvs :: TcM (InstEnv, InstEnv)
+-- Gets both the home-pkg inst env (includes module being compiled)
+-- and the external-package inst-env
+tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
+ return (tcg_inst_env env, eps_inst_env eps) }