+-- Dictionaries
+lookupInst (Dict _ pred loc)
+ = do { mb_result <- lookupPred pred
+ ; case mb_result of {
+ Nothing -> return NoInstance ;
+ Just (tenv, dfun_id) -> do
+
+ -- tenv is a substitution that instantiates the dfun_id
+ -- to match the requested result type.
+ --
+ -- We ASSUME that the dfun is quantified over the very same tyvars
+ -- that are bound by the tenv.
+ --
+ -- However, the dfun
+ -- might have some tyvars that *only* appear in arguments
+ -- dfun :: forall a b. C a b, Ord b => D [a]
+ -- We instantiate b to a flexi type variable -- it'll presumably
+ -- become fixed later via functional dependencies
+ { use_stage <- getStage
+ ; checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
+ (topIdLvl dfun_id) use_stage
+
+ -- 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 open_tvs to instantiate any un-substituted tyvars.
+ ; let (tyvars, rho) = tcSplitForAllTys (idType dfun_id)
+ open_tvs = filter (`notElemTvSubst` tenv) tyvars
+ ; open_tvs' <- mappM tcInstTyVar open_tvs
+ ; let
+ tenv' = extendTvSubstList tenv open_tvs (mkTyVarTys open_tvs')
+ -- Since the open_tvs' are freshly made, they cannot possibly be captured by
+ -- any nested for-alls in rho. So the in-scope set is unchanged
+ dfun_rho = substTy tenv' rho
+ (theta, _) = tcSplitPhiTy dfun_rho
+ ty_app = mkHsTyApp (L (instLocSrcSpan loc) (HsVar dfun_id))
+ (map (substTyVar tenv') tyvars)
+ ; if null theta then
+ returnM (SimpleInst ty_app)
+ else do
+ { dicts <- newDictsAtLoc loc theta
+ ; let rhs = mkHsDictApp ty_app (map instToId dicts)
+ ; returnM (GenInst dicts rhs)
+ }}}}
+
+---------------
+lookupPred :: TcPredType -> TcM (Maybe (TvSubst, DFunId))
+-- Look up a class constraint in the instance environment
+lookupPred pred@(ClassP clas tys)
+ = do { eps <- getEps
+ ; tcg_env <- getGblEnv
+ ; let inst_envs = (eps_inst_env eps, tcg_inst_env tcg_env)
+ ; case lookupInstEnv inst_envs clas tys of {
+ ([(tenv, ispec)], [])
+ -> do { let dfun_id = is_dfun ispec
+ ; traceTc (text "lookupInst success" <+>
+ vcat [text "dict" <+> ppr pred,
+ text "witness" <+> ppr dfun_id
+ <+> ppr (idType dfun_id) ])
+ -- Record that this dfun is needed
+ ; record_dfun_usage dfun_id
+ ; return (Just (tenv, dfun_id)) } ;
+
+ (matches, unifs)
+ -> do { traceTc (text "lookupInst fail" <+>
+ vcat [text "dict" <+> ppr pred,
+ text "matches" <+> ppr matches,
+ text "unifs" <+> ppr unifs])
+ -- 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.
+ ; return Nothing }
+ }}
+
+lookupPred ip_pred = return Nothing
+
+record_dfun_usage dfun_id
+ = do { gbl <- getGblEnv
+ ; let dfun_name = idName dfun_id
+ dfun_mod = nameModule dfun_name
+ ; if isInternalName dfun_name || -- Internal name => defined in this module
+ not (isHomeModule (tcg_home_mods gbl) dfun_mod)
+ then return () -- internal, or in another package
+ else do { tcg_env <- getGblEnv
+ ; updMutVar (tcg_inst_uses tcg_env)
+ (`addOneToNameSet` idName dfun_id) }}
+
+
+tcGetInstEnvs :: TcM (InstEnv, InstEnv)
+-- Gets both the external-package inst-env
+-- and the home-pkg inst env (includes module being compiled)
+tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
+ return (eps_inst_env eps, tcg_inst_env env) }