X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcType.lhs;h=eff458dc8b119b5510bd2a26a9b433bc1ac11fc2;hb=f7ecf7234c224489be8a5e63fced903b655d92ee;hp=b386d1ade2111ed55def40176bc30395e167c2b9;hpb=e7498a3ee1d0484d02a9e86633cc179c76ebf36e;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs index b386d1a..eff458d 100644 --- a/ghc/compiler/typecheck/TcType.lhs +++ b/ghc/compiler/typecheck/TcType.lhs @@ -3,17 +3,17 @@ module TcType ( - TcTyVar(..), + SYN_IE(TcTyVar), newTcTyVar, newTyVarTy, -- Kind -> NF_TcM s (TcType s) newTyVarTys, -- Int -> Kind -> NF_TcM s [TcType s] - TcTyVarSet(..), + SYN_IE(TcTyVarSet), ----------------------------------------- - TcType(..), TcMaybe(..), - TcTauType(..), TcThetaType(..), TcRhoType(..), + SYN_IE(TcType), TcMaybe(..), + SYN_IE(TcTauType), SYN_IE(TcThetaType), SYN_IE(TcRhoType), -- Find the type to which a type variable is bound tcWriteTyVar, -- :: TcTyVar s -> TcType s -> NF_TcM (TcType s) @@ -22,7 +22,7 @@ module TcType ( tcInstTyVars, tcInstSigTyVars, - tcInstType, tcInstSigType, tcInstTcType, + tcInstType, tcInstSigType, tcInstTcType, tcInstSigTcType, tcInstTheta, tcInstId, zonkTcTyVars, @@ -36,13 +36,13 @@ module TcType ( -- friends: -import Type ( Type(..), ThetaType(..), GenType(..), +import Type ( SYN_IE(Type), SYN_IE(ThetaType), GenType(..), tyVarsOfTypes, getTyVar_maybe, splitForAllTy, splitRhoTy, mkForAllTys, instantiateTy ) -import TyVar ( TyVar(..), GenTyVar(..), TyVarSet(..), GenTyVarSet(..), - TyVarEnv(..), lookupTyVarEnv, addOneToTyVarEnv, +import TyVar ( SYN_IE(TyVar), GenTyVar(..), SYN_IE(TyVarSet), SYN_IE(GenTyVarSet), + SYN_IE(TyVarEnv), lookupTyVarEnv, addOneToTyVarEnv, nullTyVarEnv, mkTyVarEnv, tyVarSetToList ) @@ -53,20 +53,20 @@ import Id ( idType ) import Kind ( Kind ) import TcKind ( TcKind ) import TcMonad hiding ( rnMtoTcM ) -import Usage ( Usage(..), GenUsage, UVar(..), duffUsage ) +import Usage ( SYN_IE(Usage), GenUsage, SYN_IE(UVar), duffUsage ) -import TysWiredIn ( voidTy ) +import TysPrim ( voidTy ) IMP_Ubiq() import Unique ( Unique ) import UniqFM ( UniqFM ) import Maybes ( assocMaybe ) -import Util ( zipEqual, nOfThem, panic, pprPanic, pprTrace{-ToDo:rm-} ) +import Util ( zipEqual, nOfThem, panic{-, pprPanic, pprTrace ToDo:rm-} ) -import Outputable ( Outputable(..) ) -- Debugging messages -import PprType ( GenTyVar, GenType ) -import Pretty -- ditto -import PprStyle ( PprStyle(..) ) -- ditto +--import Outputable ( Outputable(..) ) -- Debugging messages +--import PprType ( GenTyVar, GenType ) +--import Pretty -- ditto +--import PprStyle ( PprStyle(..) ) -- ditto \end{code} @@ -170,6 +170,15 @@ tcInstTcType ty where (tyvars, rho) = splitForAllTy ty +tcInstSigTcType :: TcType s -> NF_TcM s ([TcTyVar s], TcType s) +tcInstSigTcType ty + = case tyvars of + [] -> returnNF_Tc ([], ty) -- Nothing to do + other -> tcInstSigTyVars tyvars `thenNF_Tc` \ (tyvars', _, tenv) -> + returnNF_Tc (tyvars', instantiateTy tenv rho) + where + (tyvars, rho) = splitForAllTy ty + tcInstType :: [(GenTyVar flexi,TcType s)] -> GenType (GenTyVar flexi) UVar -> NF_TcM s (TcType s) @@ -179,8 +188,8 @@ tcInstType tenv ty_to_inst bind_fn = inst_tyvar UnBound occ_fn env tyvar = case lookupTyVarEnv env tyvar of Just ty -> returnNF_Tc ty - Nothing -> pprPanic "tcInstType:" (ppAboves [ppr PprDebug ty_to_inst, - ppr PprDebug tyvar]) + Nothing -> panic "tcInstType:1" --(ppAboves [ppr PprDebug ty_to_inst, + -- ppr PprDebug tyvar]) tcInstSigType :: GenType (GenTyVar flexi) UVar -> NF_TcM s (TcType s) tcInstSigType ty_to_inst @@ -189,8 +198,8 @@ tcInstSigType ty_to_inst bind_fn = inst_tyvar DontBind occ_fn env tyvar = case lookupTyVarEnv env tyvar of Just ty -> returnNF_Tc ty - Nothing -> pprPanic "tcInstType:" (ppAboves [ppr PprDebug ty_to_inst, - ppr PprDebug tyvar]) + Nothing -> panic "tcInstType:2"-- (ppAboves [ppr PprDebug ty_to_inst, + -- ppr PprDebug tyvar]) zonkTcTyVarToTyVar :: TcTyVar s -> NF_TcM s TyVar zonkTcTyVarToTyVar tv @@ -199,7 +208,7 @@ zonkTcTyVarToTyVar tv TyVarTy tv' -> returnNF_Tc (tcTyVarToTyVar tv') - _ -> pprTrace "zonkTcTyVarToTyVar:" (ppCat [ppr PprDebug tv, ppr PprDebug tv_ty]) $ + _ -> --pprTrace "zonkTcTyVarToTyVar:" (ppCat [ppr PprDebug tv, ppr PprDebug tv_ty]) $ returnNF_Tc (tcTyVarToTyVar tv) @@ -220,37 +229,37 @@ zonkTcTypeToType env ty tcConvert bind_fn occ_fn env ty_to_convert - = do env ty_to_convert + = doo env ty_to_convert where - do env (TyConTy tycon usage) = returnNF_Tc (TyConTy tycon usage) + doo env (TyConTy tycon usage) = returnNF_Tc (TyConTy tycon usage) - do env (SynTy tycon tys ty) = mapNF_Tc (do env) tys `thenNF_Tc` \ tys' -> - do env ty `thenNF_Tc` \ ty' -> + doo env (SynTy tycon tys ty) = mapNF_Tc (doo env) tys `thenNF_Tc` \ tys' -> + doo env ty `thenNF_Tc` \ ty' -> returnNF_Tc (SynTy tycon tys' ty') - do env (FunTy arg res usage) = do env arg `thenNF_Tc` \ arg' -> - do env res `thenNF_Tc` \ res' -> + doo env (FunTy arg res usage) = doo env arg `thenNF_Tc` \ arg' -> + doo env res `thenNF_Tc` \ res' -> returnNF_Tc (FunTy arg' res' usage) - do env (AppTy fun arg) = do env fun `thenNF_Tc` \ fun' -> - do env arg `thenNF_Tc` \ arg' -> + doo env (AppTy fun arg) = doo env fun `thenNF_Tc` \ fun' -> + doo env arg `thenNF_Tc` \ arg' -> returnNF_Tc (AppTy fun' arg') - do env (DictTy clas ty usage)= do env ty `thenNF_Tc` \ ty' -> + doo env (DictTy clas ty usage)= doo env ty `thenNF_Tc` \ ty' -> returnNF_Tc (DictTy clas ty' usage) - do env (ForAllUsageTy u us ty) = do env ty `thenNF_Tc` \ ty' -> + doo env (ForAllUsageTy u us ty) = doo env ty `thenNF_Tc` \ ty' -> returnNF_Tc (ForAllUsageTy u us ty') -- The two interesting cases! - do env (TyVarTy tv) = occ_fn env tv + doo env (TyVarTy tv) = occ_fn env tv - do env (ForAllTy tyvar ty) + doo env (ForAllTy tyvar ty) = bind_fn tyvar `thenNF_Tc` \ tyvar' -> let new_env = addOneToTyVarEnv env tyvar (TyVarTy tyvar') in - do new_env ty `thenNF_Tc` \ ty' -> + doo new_env ty `thenNF_Tc` \ ty' -> returnNF_Tc (ForAllTy tyvar' ty') @@ -367,7 +376,7 @@ zonkTcType (ForAllTy tv ty) case tv_ty of -- Should be a tyvar! TyVarTy tv' -> returnNF_Tc (ForAllTy tv' ty') - _ -> pprTrace "zonkTcType:ForAllTy:" (ppCat [ppr PprDebug tv, ppr PprDebug tv_ty]) $ + _ -> --pprTrace "zonkTcType:ForAllTy:" (ppCat [ppr PprDebug tv, ppr PprDebug tv_ty]) $ returnNF_Tc (ForAllTy tv{-(tcTyVarToTyVar tv)-} ty')