-lookupInst dict@(Dict _ pred@(ClassP clas tys) loc)
- = do { dflags <- getDOpts
- ; if all tcIsTyVarTy tys &&
- not (dopt Opt_AllowUndecidableInstances dflags)
- -- Common special case; no lookup
- -- NB: tcIsTyVarTy... don't look through newtypes!
- -- Don't take this short cut if we allow undecidable instances
- -- because we might have "instance T a where ...".
- -- [That means we need -fallow-undecidable-instances in the
- -- client module, as well as the module with the instance decl.]
- then return NoInstance
-
- else do
- { pkg_ie <- loadImportedInsts clas tys
- -- Suck in any instance decls that may be relevant
+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