X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcType.lhs;h=eff458dc8b119b5510bd2a26a9b433bc1ac11fc2;hb=f7ecf7234c224489be8a5e63fced903b655d92ee;hp=0a602c731c66b33c9fbbe90d5766530d6830ec72;hpb=5cf27e8f1731c52fe63a5b9615f927484164c61b;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs index 0a602c7..eff458d 100644 --- a/ghc/compiler/typecheck/TcType.lhs +++ b/ghc/compiler/typecheck/TcType.lhs @@ -1,30 +1,34 @@ \begin{code} +#include "HsVersions.h" + 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) tcReadTyVar, -- :: TcTyVar s -> NF_TcM (TcMaybe s) - tcInstTyVars, -- TyVar -> NF_TcM s (TcTyVar s) + tcInstTyVars, tcInstSigTyVars, - tcInstType, tcInstTheta, tcInstId, + tcInstType, tcInstSigType, tcInstTcType, tcInstSigTcType, + tcInstTheta, tcInstId, zonkTcTyVars, zonkTcType, zonkTcTypeToType, + zonkTcTyVar, zonkTcTyVarToTyVar ) where @@ -32,12 +36,14 @@ module TcType ( -- friends: -import Type ( Type(..), ThetaType(..), GenType(..), +import Type ( SYN_IE(Type), SYN_IE(ThetaType), GenType(..), tyVarsOfTypes, getTyVar_maybe, - splitForAllTy, splitRhoTy + splitForAllTy, splitRhoTy, + mkForAllTys, instantiateTy ) -import TyVar ( TyVar(..), GenTyVar(..), TyVarSet(..), GenTyVarSet(..), - TyVarEnv(..), lookupTyVarEnv, addOneToTyVarEnv, mkTyVarEnv, +import TyVar ( SYN_IE(TyVar), GenTyVar(..), SYN_IE(TyVarSet), SYN_IE(GenTyVarSet), + SYN_IE(TyVarEnv), lookupTyVarEnv, addOneToTyVarEnv, + nullTyVarEnv, mkTyVarEnv, tyVarSetToList ) @@ -47,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 ) -import Ubiq +IMP_Ubiq() import Unique ( Unique ) import UniqFM ( UniqFM ) import Maybes ( assocMaybe ) -import Util ( zipEqual, nOfThem, panic, pprPanic ) +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} @@ -121,15 +127,14 @@ newTyVarTys :: Int -> Kind -> NF_TcM s [TcType s] newTyVarTys n kind = mapNF_Tc newTyVarTy (nOfThem n kind) - -- For signature type variables, mark them as "DontBind" tcInstTyVars, tcInstSigTyVars :: [GenTyVar flexi] -> NF_TcM s ([TcTyVar s], [TcType s], [(GenTyVar flexi, TcType s)]) + tcInstTyVars tyvars = inst_tyvars UnBound tyvars tcInstSigTyVars tyvars = inst_tyvars DontBind tyvars - inst_tyvars initial_cts tyvars = mapNF_Tc (inst_tyvar initial_cts) tyvars `thenNF_Tc` \ tc_tyvars -> let @@ -143,34 +148,69 @@ inst_tyvar initial_cts (TyVar _ kind name _) returnNF_Tc (TyVar uniq kind name box) \end{code} -@tcInstType@ and @tcInstTcType@ both create a fresh instance of a +@tcInstType@ and @tcInstSigType@ both create a fresh instance of a type, returning a @TcType@. All inner for-alls are instantiated with fresh TcTyVars. -There are two versions, one for instantiating a @Type@, and one for a @TcType@. -The former must instantiate everything; all tyvars must be bound either -by a forall or by an environment passed in. The latter can do some sharing, -and is happy with free tyvars (which is vital when instantiating the type -of local functions). In the future @tcInstType@ may try to be clever about not -instantiating constant sub-parts. +The difference is that tcInstType instantiates all forall'd type +variables (and their bindees) with UnBound type variables, whereas +tcInstSigType instantiates them with DontBind types variables. +@tcInstSigType@ also doesn't take an environment. + +On the other hand, @tcInstTcType@ instantiates a TcType. It uses +instantiateTy which could take advantage of sharing some day. \begin{code} +tcInstTcType :: TcType s -> NF_TcM s ([TcTyVar s], TcType s) +tcInstTcType ty + = case tyvars of + [] -> returnNF_Tc ([], ty) -- Nothing to do + other -> tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', _, tenv) -> + returnNF_Tc (tyvars', instantiateTy tenv rho) + 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) tcInstType tenv ty_to_inst = tcConvert bind_fn occ_fn (mkTyVarEnv tenv) ty_to_inst where + bind_fn = inst_tyvar UnBound + occ_fn env tyvar = case lookupTyVarEnv env tyvar of + Just ty -> returnNF_Tc ty + 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 + = tcConvert bind_fn occ_fn nullTyVarEnv ty_to_inst + where 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 tyvar - = zonkTcTyVar tyvar `thenNF_Tc` \ (TyVarTy tyvar') -> - returnNF_Tc (tcTyVarToTyVar tyvar') +zonkTcTyVarToTyVar tv + = zonkTcTyVar tv `thenNF_Tc` \ tv_ty -> + case tv_ty of -- Should be a tyvar! + + TyVarTy tv' -> returnNF_Tc (tcTyVarToTyVar tv') + + _ -> --pprTrace "zonkTcTyVarToTyVar:" (ppCat [ppr PprDebug tv, ppr PprDebug tv_ty]) $ + returnNF_Tc (tcTyVarToTyVar tv) + zonkTcTypeToType :: TyVarEnv Type -> TcType s -> NF_TcM s Type zonkTcTypeToType env ty @@ -189,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') @@ -331,9 +371,14 @@ zonkTcType (SynTy tc tys ty) returnNF_Tc (SynTy tc tys' ty') zonkTcType (ForAllTy tv ty) - = zonkTcTyVar tv `thenNF_Tc` \ (TyVarTy tv') -> -- Should be a tyvar! + = zonkTcTyVar tv `thenNF_Tc` \ tv_ty -> zonkTcType ty `thenNF_Tc` \ ty' -> - returnNF_Tc (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]) $ + + returnNF_Tc (ForAllTy tv{-(tcTyVarToTyVar tv)-} ty') zonkTcType (ForAllUsageTy uv uvs ty) = panic "zonk:ForAllUsageTy"