X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypes%2FType.lhs;h=8ff78fbccfa5f2c082fcb1b7d39b8d1c6e4a13ab;hb=ca9e79e1c70a26b12ea4b63f3a1c5a804462c1a5;hp=f894cd304f1e0bac556c732613af689dbf0e647d;hpb=b06d623b2e367a572de5daf06d6a0b12c2740471;p=ghc-hetmet.git diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs index f894cd3..8ff78fb 100644 --- a/compiler/types/Type.lhs +++ b/compiler/types/Type.lhs @@ -6,7 +6,6 @@ Type - public interface \begin{code} -{-# OPTIONS -fno-warn-incomplete-patterns #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and fix -- any warnings in the module. See @@ -31,7 +30,7 @@ module Type ( mkFunTy, mkFunTys, splitFunTy, splitFunTy_maybe, splitFunTys, splitFunTysN, - funResultTy, funArgTy, zipFunTys, + funResultTy, funArgTy, zipFunTys, mkTyConApp, mkTyConTy, tyConAppTyCon, tyConAppArgs, @@ -47,13 +46,13 @@ module Type ( tyFamInsts, predFamInsts, -- (Source types) - mkPredTy, mkPredTys, mkFamilyTyConApp, isEqPred, + mkPredTy, mkPredTys, mkFamilyTyConApp, isEqPred, coVarPred, -- ** Common type constructors funTyCon, -- ** Predicates on types - isTyVarTy, isFunTy, + isTyVarTy, isFunTy, isDictTy, -- (Lifting and boxity) isUnLiftedType, isUnboxedTupleType, isAlgType, isClosedAlgType, @@ -77,14 +76,6 @@ module Type ( tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta, expandTypeSynonyms, - -- * Tidying type related things up for printing - tidyType, tidyTypes, - tidyOpenType, tidyOpenTypes, - tidyTyVarBndr, tidyFreeTyVars, - tidyOpenTyVar, tidyOpenTyVars, - tidyTopType, tidyPred, - tidyKind, - -- * Type comparison coreEqType, coreEqType2, tcEqType, tcEqTypes, tcCmpType, tcCmpTypes, @@ -114,7 +105,7 @@ module Type ( getTvSubstEnv, setTvSubstEnv, zapTvSubstEnv, getTvInScope, extendTvInScope, extendTvInScopeList, extendTvSubst, extendTvSubstList, isInScope, composeTvSubst, zipTyEnv, - isEmptyTvSubst, + isEmptyTvSubst, unionTvSubst, -- ** Performing substitution on types substTy, substTys, substTyWith, substTysWith, substTheta, @@ -139,7 +130,6 @@ import Var import VarEnv import VarSet -import Name import Class import TyCon @@ -149,8 +139,9 @@ import Util import Outputable import FastString -import Data.List import Data.Maybe ( isJust ) + +infixr 3 `mkFunTy` -- Associates to the right \end{code} \begin{code} @@ -467,7 +458,8 @@ splitFunTys ty = split [] ty ty splitFunTysN :: Int -> Type -> ([Type], Type) -- ^ Split off exactly the given number argument types, and panics if that is not possible splitFunTysN 0 ty = ([], ty) -splitFunTysN n ty = case splitFunTy ty of { (arg, res) -> +splitFunTysN n ty = ASSERT2( isFunTy ty, int n <+> ppr ty ) + case splitFunTy ty of { (arg, res) -> case splitFunTysN (n-1) res of { (args, res) -> (arg:args, res) }} @@ -820,6 +812,11 @@ pprSourceTyCon tycon = ppr $ fam_tc `TyConApp` tys -- can't be FunTyCon | otherwise = ppr tycon + +isDictTy :: Type -> Bool +isDictTy ty = case splitTyConApp_maybe ty of + Just (tc, _) -> isClassTyCon tc + Nothing -> False \end{code} @@ -832,12 +829,18 @@ pprSourceTyCon tycon \begin{code} tyVarsOfType :: Type -> TyVarSet -- ^ NB: for type synonyms tyVarsOfType does /not/ expand the synonym -tyVarsOfType (TyVarTy tv) = unitVarSet tv -tyVarsOfType (TyConApp _ tys) = tyVarsOfTypes tys -tyVarsOfType (PredTy sty) = tyVarsOfPred sty -tyVarsOfType (FunTy arg res) = tyVarsOfType arg `unionVarSet` tyVarsOfType res -tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionVarSet` tyVarsOfType arg -tyVarsOfType (ForAllTy tyvar ty) = delVarSet (tyVarsOfType ty) tyvar +tyVarsOfType (TyVarTy tv) = unitVarSet tv +tyVarsOfType (TyConApp _ tys) = tyVarsOfTypes tys +tyVarsOfType (PredTy sty) = tyVarsOfPred sty +tyVarsOfType (FunTy arg res) = tyVarsOfType arg `unionVarSet` tyVarsOfType res +tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionVarSet` tyVarsOfType arg +tyVarsOfType (ForAllTy tv ty) -- The kind of a coercion binder + -- can mention type variables! + | isTyVar tv = inner_tvs `delVarSet` tv + | otherwise {- Coercion -} = -- ASSERT( not (tv `elemVarSet` inner_tvs) ) + inner_tvs `unionVarSet` tyVarsOfType (tyVarKind tv) + where + inner_tvs = tyVarsOfType ty tyVarsOfTypes :: [Type] -> TyVarSet tyVarsOfTypes tys = foldr (unionVarSet.tyVarsOfType) emptyVarSet tys @@ -865,7 +868,7 @@ tyFamInsts ty | Just exp_ty <- tcView ty = tyFamInsts exp_ty tyFamInsts (TyVarTy _) = [] tyFamInsts (TyConApp tc tys) - | isOpenSynTyCon tc = [(tc, tys)] + | isSynFamilyTyCon tc = [(tc, tys)] | otherwise = concat (map tyFamInsts tys) tyFamInsts (FunTy ty1 ty2) = tyFamInsts ty1 ++ tyFamInsts ty2 tyFamInsts (AppTy ty1 ty2) = tyFamInsts ty1 ++ tyFamInsts ty2 @@ -883,100 +886,6 @@ predFamInsts (EqPred ty1 ty2) = tyFamInsts ty1 ++ tyFamInsts ty2 %************************************************************************ %* * -\subsection{TidyType} -%* * -%************************************************************************ - -\begin{code} --- | This tidies up a type for printing in an error message, or in --- an interface file. --- --- It doesn't change the uniques at all, just the print names. -tidyTyVarBndr :: TidyEnv -> TyVar -> (TidyEnv, TyVar) -tidyTyVarBndr env@(tidy_env, subst) tyvar - = case tidyOccName tidy_env (getOccName name) of - (tidy', occ') -> ((tidy', subst'), tyvar'') - where - subst' = extendVarEnv subst tyvar tyvar'' - tyvar' = setTyVarName tyvar name' - name' = tidyNameOcc name occ' - -- Don't forget to tidy the kind for coercions! - tyvar'' | isCoVar tyvar = setTyVarKind tyvar' kind' - | otherwise = tyvar' - kind' = tidyType env (tyVarKind tyvar) - where - name = tyVarName tyvar - -tidyFreeTyVars :: TidyEnv -> TyVarSet -> TidyEnv --- ^ Add the free 'TyVar's to the env in tidy form, --- so that we can tidy the type they are free in -tidyFreeTyVars env tyvars = fst (tidyOpenTyVars env (varSetElems tyvars)) - -tidyOpenTyVars :: TidyEnv -> [TyVar] -> (TidyEnv, [TyVar]) -tidyOpenTyVars env tyvars = mapAccumL tidyOpenTyVar env tyvars - -tidyOpenTyVar :: TidyEnv -> TyVar -> (TidyEnv, TyVar) --- ^ Treat a new 'TyVar' as a binder, and give it a fresh tidy name --- using the environment if one has not already been allocated. See --- also 'tidyTyVarBndr' -tidyOpenTyVar env@(_, subst) tyvar - = case lookupVarEnv subst tyvar of - Just tyvar' -> (env, tyvar') -- Already substituted - Nothing -> tidyTyVarBndr env tyvar -- Treat it as a binder - -tidyType :: TidyEnv -> Type -> Type -tidyType env@(_, subst) ty - = go ty - where - go (TyVarTy tv) = case lookupVarEnv subst tv of - Nothing -> TyVarTy tv - Just tv' -> TyVarTy tv' - go (TyConApp tycon tys) = let args = map go tys - in args `seqList` TyConApp tycon args - go (PredTy sty) = PredTy (tidyPred env sty) - go (AppTy fun arg) = (AppTy $! (go fun)) $! (go arg) - go (FunTy fun arg) = (FunTy $! (go fun)) $! (go arg) - go (ForAllTy tv ty) = ForAllTy tvp $! (tidyType envp ty) - where - (envp, tvp) = tidyTyVarBndr env tv - -tidyTypes :: TidyEnv -> [Type] -> [Type] -tidyTypes env tys = map (tidyType env) tys - -tidyPred :: TidyEnv -> PredType -> PredType -tidyPred env (IParam n ty) = IParam n (tidyType env ty) -tidyPred env (ClassP clas tys) = ClassP clas (tidyTypes env tys) -tidyPred env (EqPred ty1 ty2) = EqPred (tidyType env ty1) (tidyType env ty2) -\end{code} - - -\begin{code} --- | Grabs the free type variables, tidies them --- and then uses 'tidyType' to work over the type itself -tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type) -tidyOpenType env ty - = (env', tidyType env' ty) - where - env' = tidyFreeTyVars env (tyVarsOfType ty) - -tidyOpenTypes :: TidyEnv -> [Type] -> (TidyEnv, [Type]) -tidyOpenTypes env tys = mapAccumL tidyOpenType env tys - --- | Calls 'tidyType' on a top-level type (i.e. with an empty tidying environment) -tidyTopType :: Type -> Type -tidyTopType ty = tidyType emptyTidyEnv ty -\end{code} - -\begin{code} - -tidyKind :: TidyEnv -> Kind -> (TidyEnv, Kind) -tidyKind env k = tidyOpenType env k - -\end{code} - - -%************************************************************************ -%* * \subsection{Liftedness} %* * %************************************************************************ @@ -1018,7 +927,7 @@ isClosedAlgType :: Type -> Bool isClosedAlgType ty = case splitTyConApp_maybe ty of Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc ) - isAlgTyCon tc && not (isOpenTyCon tc) + isAlgTyCon tc && not (isFamilyTyCon tc) _other -> False \end{code} @@ -1330,7 +1239,7 @@ then (substTy subst ty) does nothing. For example, consider: (/\a. /\b:(a~Int). ...b..) Int We substitute Int for 'a'. The Unique of 'b' does not change, but -nevertheless we add 'b' to the TvSubstEnv, because b's type does change +nevertheless we add 'b' to the TvSubstEnv, because b's kind does change This invariant has several crucial consequences: @@ -1411,6 +1320,13 @@ extendTvSubstList :: TvSubst -> [TyVar] -> [Type] -> TvSubst extendTvSubstList (TvSubst in_scope env) tvs tys = TvSubst in_scope (extendVarEnvList env (tvs `zip` tys)) +unionTvSubst :: TvSubst -> TvSubst -> TvSubst +-- Works when the ranges are disjoint +unionTvSubst (TvSubst in_scope1 env1) (TvSubst in_scope2 env2) + = ASSERT( not (env1 `intersectsVarEnv` env2) ) + TvSubst (in_scope1 `unionInScope` in_scope2) + (env1 `plusVarEnv` env2) + -- mkOpenTvSubst and zipOpenTvSubst generate the in-scope set from -- the types given; but it's just a thunk so with a bit of luck -- it'll never be evaluated