X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=compiler%2Ftypecheck%2FInst.lhs;h=a45422adb357052b5b565b402e9bd0623fa8480a;hb=1e436f2bb208a6c990743afaf17b7c2a93c31742;hp=cada794388baf4aace9f23eded36348fd099276b;hpb=0ae16401a0c73548ba4c08f588174f618c363a73;p=ghc-hetmet.git diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs index cada794..a45422a 100644 --- a/compiler/typecheck/Inst.lhs +++ b/compiler/typecheck/Inst.lhs @@ -20,11 +20,11 @@ module Inst ( cloneDict, mkOverLit, newIPDict, newMethod, newMethodFromName, newMethodWithGivenTy, tcInstClassOp, - tcSyntaxName, isHsVar, + tcSyntaxName, - tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE, - ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts, - growInstsTyVars, getDictClassTys, dictPred, + tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE, tcTyVarsOfInst, + tcTyVarsOfInsts, ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, + fdPredsOfInsts, growInstsTyVars, getDictClassTys, dictPred, lookupSimpleInst, LookupInstResult(..), tcExtendLocalInstEnv, tcGetInstEnvs, getOverlapFlag, @@ -62,7 +62,7 @@ import InstEnv import FunDeps import TcMType import TcType -import MkCore +import MkCore ( mkBigCoreTupTy ) import TyCon import Type import TypeRep @@ -193,22 +193,53 @@ ipNamesOfInst (Method {tci_theta = theta}) = [ipNameName n | IParam n _ <- the ipNamesOfInst _ = [] --------------------------------- -tyVarsOfInst :: Inst -> TcTyVarSet + +-- |All free type variables (not including the coercion variables of +-- equalities) +-- +tyVarsOfInst :: Inst -> TyVarSet tyVarsOfInst (LitInst {tci_ty = ty}) = tyVarsOfType ty tyVarsOfInst (Dict {tci_pred = pred}) = tyVarsOfPred pred -tyVarsOfInst (Method {tci_oid = id, tci_tys = tys}) = tyVarsOfTypes tys `unionVarSet` varTypeTyVars id - -- The id might have free type variables; in the case of - -- locally-overloaded class methods, for example -tyVarsOfInst (ImplicInst {tci_tyvars = tvs, tci_given = givens, tci_wanted = wanteds}) +tyVarsOfInst (Method {tci_oid = id, tci_tys = tys}) + = tyVarsOfTypes tys `unionVarSet` varTypeTyVars id + -- The id might have free type variables; in the case of + -- locally-overloaded class methods, for example +tyVarsOfInst (ImplicInst {tci_tyvars = tvs, tci_given = givens, + tci_wanted = wanteds}) = (tyVarsOfInsts givens `unionVarSet` tyVarsOfInsts wanteds) `minusVarSet` mkVarSet tvs `unionVarSet` unionVarSets (map varTypeTyVars tvs) -- Remember the free tyvars of a coercion -tyVarsOfInst (EqInst {tci_left = ty1, tci_right = ty2}) = tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2 +tyVarsOfInst (EqInst {tci_left = ty1, tci_right = ty2}) + = tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2 -tyVarsOfInsts :: [Inst] -> VarSet +-- |All free meta type variables *including* the coercion variables of +-- equalities +-- +tcTyVarsOfInst :: Inst -> TyVarSet +tcTyVarsOfInst (LitInst {tci_ty = ty}) = tcTyVarsOfType ty +tcTyVarsOfInst (Dict {tci_pred = pred}) = tcTyVarsOfPred pred +tcTyVarsOfInst (Method {tci_oid = id, tci_tys = tys}) + = tcTyVarsOfTypes tys `unionVarSet` varTypeTcTyVars id + -- The id might have free type variables; in the case of + -- locally-overloaded class methods, for example +tcTyVarsOfInst (ImplicInst {tci_tyvars = tvs, tci_given = givens, + tci_wanted = wanteds}) + = (tcTyVarsOfInsts givens `unionVarSet` tcTyVarsOfInsts wanteds) + `minusVarSet` mkVarSet tvs + `unionVarSet` unionVarSets (map varTypeTcTyVars tvs) + -- Remember the free tyvars of a coercion +tcTyVarsOfInst (EqInst {tci_co = co, tci_left = ty1, tci_right = ty2}) + = either unitVarSet tcTyVarsOfType co `unionVarSet` -- include covars + tcTyVarsOfType ty1 `unionVarSet` tcTyVarsOfType ty2 + +tyVarsOfInsts :: [Inst] -> TyVarSet tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts -tyVarsOfLIE :: Bag Inst -> VarSet + +tcTyVarsOfInsts :: [Inst] -> TcTyVarSet +tcTyVarsOfInsts insts = foldr (unionVarSet . tcTyVarsOfInst) emptyVarSet insts + +tyVarsOfLIE :: Bag Inst -> TyVarSet tyVarsOfLIE lie = tyVarsOfInsts (lieToList lie) @@ -539,10 +570,6 @@ mkOverLit (HsFractional r) ; return (HsRat r rat_ty) } mkOverLit (HsIsString s) = return (HsString s) - -isHsVar :: HsExpr Name -> Name -> Bool -isHsVar (HsVar f) g = f == g -isHsVar _ _ = False \end{code} @@ -840,7 +867,7 @@ lookupSimpleInst (Dict {tci_pred = pred, tci_loc = loc}) { use_stage <- getStage ; checkWellStaged (ptext (sLit "instance for") <+> quotes (ppr pred)) - (topIdLvl dfun_id) use_stage + (topIdLvl dfun_id) (thLevel use_stage) -- It's possible that not all the tyvars are in -- the substitution, tenv. For example: @@ -1029,7 +1056,7 @@ depending on whether a EqInstCo is for a wanted or local equality: -- mkIdEqInstCo :: EqInstCo -> Type -> TcM () mkIdEqInstCo (Left cotv) t - = writeMetaTyVar cotv t + = bindMetaTyVar cotv t mkIdEqInstCo (Right _) _ = return () @@ -1038,7 +1065,7 @@ mkIdEqInstCo (Right _) _ mkSymEqInstCo :: EqInstCo -> (Type, Type) -> TcM EqInstCo mkSymEqInstCo (Left cotv) (ty1, ty2) = do { cotv' <- newMetaCoVar ty1 ty2 - ; writeMetaTyVar cotv (mkSymCoercion (TyVarTy cotv')) + ; bindMetaTyVar cotv (mkSymCoercion (TyVarTy cotv')) ; return $ Left cotv' } mkSymEqInstCo (Right co) _ @@ -1049,7 +1076,7 @@ mkSymEqInstCo (Right co) _ mkLeftTransEqInstCo :: EqInstCo -> Coercion -> (Type, Type) -> TcM EqInstCo mkLeftTransEqInstCo (Left cotv) given_co (ty1, ty2) = do { cotv' <- newMetaCoVar ty1 ty2 - ; writeMetaTyVar cotv (TyVarTy cotv' `mkTransCoercion` given_co) + ; bindMetaTyVar cotv (TyVarTy cotv' `mkTransCoercion` given_co) ; return $ Left cotv' } mkLeftTransEqInstCo (Right co) given_co _ @@ -1060,7 +1087,7 @@ mkLeftTransEqInstCo (Right co) given_co _ mkRightTransEqInstCo :: EqInstCo -> Coercion -> (Type, Type) -> TcM EqInstCo mkRightTransEqInstCo (Left cotv) given_co (ty1, ty2) = do { cotv' <- newMetaCoVar ty1 ty2 - ; writeMetaTyVar cotv (given_co `mkTransCoercion` TyVarTy cotv') + ; bindMetaTyVar cotv (given_co `mkTransCoercion` TyVarTy cotv') ; return $ Left cotv' } mkRightTransEqInstCo (Right co) given_co _ @@ -1073,7 +1100,7 @@ mkAppEqInstCo :: EqInstCo -> (Type, Type) -> (Type, Type) mkAppEqInstCo (Left cotv) (ty1_l, ty2_l) (ty1_r, ty2_r) = do { cotv_l <- newMetaCoVar ty1_l ty2_l ; cotv_r <- newMetaCoVar ty1_r ty2_r - ; writeMetaTyVar cotv (mkAppCoercion (TyVarTy cotv_l) (TyVarTy cotv_r)) + ; bindMetaTyVar cotv (mkAppCoercion (TyVarTy cotv_l) (TyVarTy cotv_r)) ; return (Left cotv_l, Left cotv_r) } mkAppEqInstCo (Right co) _ _ @@ -1084,7 +1111,7 @@ mkAppEqInstCo (Right co) _ _ mkTyConEqInstCo :: EqInstCo -> TyCon -> [(Type, Type)] -> TcM ([EqInstCo]) mkTyConEqInstCo (Left cotv) con ty12s = do { cotvs <- mapM (uncurry newMetaCoVar) ty12s - ; writeMetaTyVar cotv (mkTyConCoercion con (mkTyVarTys cotvs)) + ; bindMetaTyVar cotv (mkTyConCoercion con (mkTyVarTys cotvs)) ; return (map Left cotvs) } mkTyConEqInstCo (Right co) _ args @@ -1102,7 +1129,7 @@ mkFunEqInstCo :: EqInstCo -> (Type, Type) -> (Type, Type) mkFunEqInstCo (Left cotv) (ty1_l, ty2_l) (ty1_r, ty2_r) = do { cotv_l <- newMetaCoVar ty1_l ty2_l ; cotv_r <- newMetaCoVar ty1_r ty2_r - ; writeMetaTyVar cotv (mkFunCoercion (TyVarTy cotv_l) (TyVarTy cotv_r)) + ; bindMetaTyVar cotv (mkFunCoercion (TyVarTy cotv_l) (TyVarTy cotv_r)) ; return (Left cotv_l, Left cotv_r) } mkFunEqInstCo (Right co) _ _ @@ -1146,7 +1173,7 @@ mkEqInst (EqPred ty1 ty2) co ; return inst } where - mkName uniq src_span = mkInternalName uniq (mkVarOcc "co") src_span + mkName uniq src_span = mkInternalName uniq (mkVarOcc "co_ei") src_span mkEqInst pred _ = pprPanic "mkEqInst" (ppr pred) mkWantedEqInst :: PredType -> TcM Inst