+-- Dictionaries
+lookupInst dict@(Dict _ pred@(ClassP clas tys) loc)
+ = 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 fail" <+> vcat [text "dict" <+> ppr pred,
+ 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 :: TvSubst -> DFunId -> TcPredType -> InstLoc -> TcM LookupInstResult
+instantiate_dfun tenv dfun_id pred loc
+ = -- 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
+ traceTc (text "lookupInst success" <+>
+ vcat [text "dict" <+> ppr pred,
+ text "witness" <+> ppr dfun_id <+> ppr (idType dfun_id) ]) `thenM_`
+ -- Record that this dfun is needed
+ record_dfun_usage dfun_id `thenM_`
+
+ getStage `thenM` \ use_stage ->
+ checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
+ (topIdLvl dfun_id) use_stage `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 open_tvs to instantiate any un-substituted tyvars.
+ let
+ (tyvars, rho) = tcSplitForAllTys (idType dfun_id)
+ open_tvs = filter (`notElemTvSubst` tenv) tyvars
+ in
+ mappM tcInstTyVar open_tvs `thenM` \ 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)
+ 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 = do
+ dflags <- getDOpts
+ let dfun_name = idName dfun_id
+ dfun_mod = nameModule dfun_name
+ if isInternalName dfun_name || not (isHomeModule dflags 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) }
+\end{code}