- loc = instLocSpan iloc
-
---------------------- Dictionaries ------------------------
-lookupSimpleInst (Dict {tci_pred = pred, tci_loc = loc})
- = do { mb_result <- lookupPred pred
- ; case mb_result of {
- Nothing -> return NoInstance ;
- Just (dfun_id, mb_inst_tys) -> do
-
- { 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 mb_inst_tys :: Either TyVar TcType
-
- ; let inst_tv (Left tv) = do { tv' <- tcInstTyVar tv; return (mkTyVarTy tv') }
- inst_tv (Right ty) = return ty
- ; tys <- mapM inst_tv mb_inst_tys
- ; let
- (theta, _) = tcSplitPhiTy (applyTys (idType dfun_id) tys)
- src_loc = instLocSpan loc
- dfun = HsVar dfun_id
- ; if null theta then
- return (GenInst [] (L src_loc $ HsWrap (mkWpTyApps tys) dfun))
- else do
- { (dict_app, dicts) <- getLIE $ instCallDicts loc theta -- !!!
- ; let co_fn = dict_app <.> mkWpTyApps tys
- ; return (GenInst dicts (L src_loc $ HsWrap co_fn dfun))
- }}}}
-
----------------
-lookupPred :: TcPredType -> TcM (Maybe (DFunId, [Either TyVar TcType]))
--- 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 {
- ([(ispec, inst_tys)], [])
- -> 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 (dfun_id, inst_tys)) } ;
-
- (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 (IParam {}) = return Nothing -- Implicit parameters
-lookupPred (EqPred {}) = panic "lookupPred EqPred"
-
-record_dfun_usage dfun_id
- = do { hsc_env <- getTopEnv
- ; let dfun_name = idName dfun_id
- dfun_mod = nameModule dfun_name
- ; if isInternalName dfun_name || -- Internal name => defined in this module
- modulePackageId dfun_mod /= thisPackage (hsc_dflags hsc_env)
- 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}
-
-
-
-%************************************************************************
-%* *
- Re-mappable syntax
-%* *
-%************************************************************************
-
-Suppose we are doing the -fno-implicit-prelude thing, and we encounter
-a do-expression. We have to find (>>) in the current environment, which is
-done by the rename. Then we have to check that it has the same type as
-Control.Monad.(>>). Or, more precisely, a compatible type. One 'customer' had
-this:
-
- (>>) :: HB m n mn => m a -> n b -> mn b
-
-So the idea is to generate a local binding for (>>), thus:
-
- let then72 :: forall a b. m a -> m b -> m b
- then72 = ...something involving the user's (>>)...
- in
- ...the do-expression...
-
-Now the do-expression can proceed using then72, which has exactly
-the expected type.
-
-In fact tcSyntaxName just generates the RHS for then72, because we only
-want an actual binding in the do-expression case. For literals, we can
-just use the expression inline.
-
-\begin{code}
-tcSyntaxName :: InstOrigin
- -> TcType -- Type to instantiate it at
- -> (Name, HsExpr Name) -- (Standard name, user name)
- -> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression)
--- *** NOW USED ONLY FOR CmdTop (sigh) ***
--- NB: tcSyntaxName calls tcExpr, and hence can do unification.
--- So we do not call it from lookupInst, which is called from tcSimplify
+ (env1, tvs') = mapAccumL tidyTyVarBndr env (varSetElems tvs)
+
+tidyEvVar :: TidyEnv -> EvVar -> EvVar
+tidyEvVar env var = setVarType var (tidyType env (varType var))
+
+tidyWantedEvVar :: TidyEnv -> WantedEvVar -> WantedEvVar
+tidyWantedEvVar env (EvVarX v l) = EvVarX (tidyEvVar env v) l
+
+tidyWantedEvVars :: TidyEnv -> Bag WantedEvVar -> Bag WantedEvVar
+tidyWantedEvVars env = mapBag (tidyWantedEvVar env)
+
+tidyFlavoredEvVar :: TidyEnv -> FlavoredEvVar -> FlavoredEvVar
+tidyFlavoredEvVar env (EvVarX v fl)
+ = EvVarX (tidyEvVar env v) (tidyFlavor env fl)
+
+tidyFlavor :: TidyEnv -> CtFlavor -> CtFlavor
+tidyFlavor env (Given loc) = Given (tidyGivenLoc env loc)
+tidyFlavor _ fl = fl
+
+tidyGivenLoc :: TidyEnv -> GivenLoc -> GivenLoc
+tidyGivenLoc env (CtLoc skol span ctxt) = CtLoc (tidySkolemInfo env skol) span ctxt
+
+tidySkolemInfo :: TidyEnv -> SkolemInfo -> SkolemInfo
+tidySkolemInfo env (SigSkol cx ty) = SigSkol cx (tidyType env ty)
+tidySkolemInfo env (InferSkol ids) = InferSkol (mapSnd (tidyType env) ids)
+tidySkolemInfo _ info = info
+
+---------------- Substitution -------------------------
+substWC :: TvSubst -> WantedConstraints -> WantedConstraints
+substWC subst (WC { wc_flat = flat, wc_impl = implic, wc_insol = insol })
+ = WC { wc_flat = substWantedEvVars subst flat
+ , wc_impl = mapBag (substImplication subst) implic
+ , wc_insol = mapBag (substFlavoredEvVar subst) insol }
+
+substImplication :: TvSubst -> Implication -> Implication
+substImplication subst implic@(Implic { ic_skols = tvs
+ , ic_given = given
+ , ic_wanted = wanted
+ , ic_loc = loc })
+ = implic { ic_skols = mkVarSet tvs'
+ , ic_given = map (substEvVar subst1) given
+ , ic_wanted = substWC subst1 wanted
+ , ic_loc = substGivenLoc subst1 loc }
+ where
+ (subst1, tvs') = mapAccumL substTyVarBndr subst (varSetElems tvs)