X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypes%2FType.lhs;h=3a8675edca3fe339eea74ddb7e36ff173eef79da;hp=662dd6f993d1e62e3407373baa05c2241013d1d5;hb=c8c2f6bb7d79a2a6aeaa3233363fdf0bbbfad205;hpb=40739684494d88dde2efad64f15be2acbcc884a2 diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs index 662dd6f..3a8675e 100644 --- a/compiler/types/Type.lhs +++ b/compiler/types/Type.lhs @@ -6,107 +6,126 @@ Type - public interface \begin{code} -{-# OPTIONS -w #-} -- 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 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings -- for details +-- | Main functions for manipulating types and type-related things module Type ( - -- re-exports from TypeRep - TyThing(..), Type, PredType(..), ThetaType, - funTyCon, + -- Note some of this is just re-exports from TyCon.. - -- Kinds - Kind, SimpleKind, KindVar, - kindFunResult, splitKindFunTys, splitKindFunTysN, - - liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon, - argTypeKindTyCon, ubxTupleKindTyCon, - - liftedTypeKind, unliftedTypeKind, openTypeKind, - argTypeKind, ubxTupleKind, - - tySuperKind, coSuperKind, - - isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind, - isUbxTupleKind, isArgTypeKind, isKind, isTySuperKind, - isCoSuperKind, isSuperKind, isCoercionKind, isEqPred, - mkArrowKind, mkArrowKinds, + -- * Main data types representing Types + -- $type_classification + + -- $representation_types + TyThing(..), Type, Pred(..), PredType, ThetaType, + Var, TyVar, isTyVar, - isSubArgTypeKind, isSubOpenTypeKind, isSubKind, defaultKind, eqKind, - isSubKindCon, - - -- Re-exports from TyCon - PrimRep(..), - - mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, isTyVarTy, + -- ** Constructing and deconstructing types + mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, mkAppTy, mkAppTys, splitAppTy, splitAppTys, splitAppTy_maybe, repSplitAppTy_maybe, mkFunTy, mkFunTys, splitFunTy, splitFunTy_maybe, splitFunTys, splitFunTysN, - funResultTy, funArgTy, zipFunTys, isFunTy, + funResultTy, funArgTy, zipFunTys, mkTyConApp, mkTyConTy, tyConAppTyCon, tyConAppArgs, splitTyConApp_maybe, splitTyConApp, - splitNewTyConApp_maybe, splitNewTyConApp, - - repType, typePrimRep, coreView, tcView, kindView, rttiView, - mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys, - applyTy, applyTys, isForAllTy, dropForAlls, - - -- Source types - predTypeRep, mkPredTy, mkPredTys, pprSourceTyCon, mkFamilyTyConApp, - - -- Newtypes - newTyConInstRhs, - - -- Lifting and boxity + mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys, + applyTy, applyTys, applyTysD, isForAllTy, dropForAlls, + + -- (Newtypes) + newTyConInstRhs, carefullySplitNewType_maybe, + + -- (Type families) + tyFamInsts, predFamInsts, + + -- Pred types + mkPredTy, mkPredTys, mkFamilyTyConApp, + mkDictTy, isDictLikeTy, isClassPred, + isEqPred, allPred, mkEqPred, + mkClassPred, getClassPredTys, getClassPredTys_maybe, + isTyVarClassPred, + mkIPPred, isIPPred, + + -- ** Common type constructors + funTyCon, + + -- ** Predicates on types + isTyVarTy, isFunTy, isPredTy, + isDictTy, isEqPredTy, isReflPredTy, splitPredTy_maybe, splitEqPredTy_maybe, + + -- (Lifting and boxity) isUnLiftedType, isUnboxedTupleType, isAlgType, isClosedAlgType, isPrimitiveType, isStrictType, isStrictPred, - -- Free variables + -- * Main data types representing Kinds + -- $kind_subtyping + Kind, SimpleKind, KindVar, + + -- ** Common Kinds and SuperKinds + liftedTypeKind, unliftedTypeKind, openTypeKind, + argTypeKind, ubxTupleKind, + tySuperKind, + + -- ** Common Kind type constructors + liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon, + argTypeKindTyCon, ubxTupleKindTyCon, + + -- * Type free variables tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta, - typeKind, addFreeTyVars, + exactTyVarsOfType, exactTyVarsOfTypes, expandTypeSynonyms, + typeSize, - -- Type families - tyFamInsts, + -- * Type comparison + eqType, eqTypeX, eqTypes, cmpType, cmpTypes, + eqPred, eqPredX, cmpPred, eqKind, - -- Tidying up for printing - tidyType, tidyTypes, - tidyOpenType, tidyOpenTypes, - tidyTyVarBndr, tidyFreeTyVars, - tidyOpenTyVar, tidyOpenTyVars, - tidyTopType, tidyPred, - tidyKind, + -- * Forcing evaluation of types + seqType, seqTypes, seqPred, - -- Comparison - coreEqType, tcEqType, tcEqTypes, tcCmpType, tcCmpTypes, - tcEqPred, tcCmpPred, tcEqTypeX, tcPartOfType, tcPartOfPred, + -- * Other views onto Types + coreView, tcView, - -- Seq - seqType, seqTypes, + repType, - -- Type substitutions - TvSubstEnv, emptyTvSubstEnv, -- Representation widely visible - TvSubst(..), emptyTvSubst, -- Representation visible to a few friends - mkTvSubst, mkOpenTvSubst, zipOpenTvSubst, zipTopTvSubst, mkTopTvSubst, notElemTvSubst, - getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope, - extendTvSubst, extendTvSubstList, isInScope, composeTvSubst, zipTyEnv, - isEmptyTvSubst, + -- * Type representation for the code generator + PrimRep(..), - -- Performing substitution on types - substTy, substTys, substTyWith, substTheta, - substPred, substTyVar, substTyVars, substTyVarBndr, deShadowTy, lookupTyVar, + typePrimRep, predTypeRep, - -- Pretty-printing + -- * Main type substitution data types + TvSubstEnv, -- Representation widely visible + TvSubst(..), -- Representation visible to a few friends + + -- ** Manipulating type substitutions + emptyTvSubstEnv, emptyTvSubst, + + mkTvSubst, mkOpenTvSubst, zipOpenTvSubst, zipTopTvSubst, mkTopTvSubst, notElemTvSubst, + getTvSubstEnv, setTvSubstEnv, + zapTvSubstEnv, getTvInScope, + extendTvInScope, extendTvInScopeList, + extendTvSubst, extendTvSubstList, + isInScope, composeTvSubst, zipTyEnv, + isEmptyTvSubst, unionTvSubst, + + -- ** Performing substitution on types + substTy, substTys, substTyWith, substTysWith, substTheta, + substPred, substTyVar, substTyVars, substTyVarBndr, + deShadowTy, lookupTyVar, + + -- * Pretty-printing pprType, pprParendType, pprTypeApp, pprTyThingCategory, pprTyThing, pprForAll, - pprPred, pprTheta, pprThetaArrow, pprClassPred, pprKind, pprParendKind + pprPred, pprPredTy, pprEqPred, pprTheta, pprThetaArrowTy, pprClassPred, + pprKind, pprParendKind, + + pprSourceTyCon ) where #include "HsVersions.h" @@ -121,21 +140,80 @@ import Var import VarEnv import VarSet -import Name import Class -import PrelNames import TyCon +import TysPrim -- others +import BasicTypes ( IPName ) +import Name ( Name ) import StaticFlags import Util import Outputable -import UniqSet +import FastString -import Data.List import Data.Maybe ( isJust ) + +infixr 3 `mkFunTy` -- Associates to the right \end{code} +\begin{code} +-- $type_classification +-- #type_classification# +-- +-- Types are one of: +-- +-- [Unboxed] Iff its representation is other than a pointer +-- Unboxed types are also unlifted. +-- +-- [Lifted] Iff it has bottom as an element. +-- Closures always have lifted types: i.e. any +-- let-bound identifier in Core must have a lifted +-- type. Operationally, a lifted object is one that +-- can be entered. +-- Only lifted types may be unified with a type variable. +-- +-- [Algebraic] Iff it is a type with one or more constructors, whether +-- declared with @data@ or @newtype@. +-- An algebraic type is one that can be deconstructed +-- with a case expression. This is /not/ the same as +-- lifted types, because we also include unboxed +-- tuples in this classification. +-- +-- [Data] Iff it is a type declared with @data@, or a boxed tuple. +-- +-- [Primitive] Iff it is a built-in type that can't be expressed in Haskell. +-- +-- Currently, all primitive types are unlifted, but that's not necessarily +-- the case: for example, @Int@ could be primitive. +-- +-- Some primitive types are unboxed, such as @Int#@, whereas some are boxed +-- but unlifted (such as @ByteArray#@). The only primitive types that we +-- classify as algebraic are the unboxed tuples. +-- +-- Some examples of type classifications that may make this a bit clearer are: +-- +-- @ +-- Type primitive boxed lifted algebraic +-- ----------------------------------------------------------------------------- +-- Int# Yes No No No +-- ByteArray# Yes Yes No No +-- (\# a, b \#) Yes No No Yes +-- ( a, b ) No Yes Yes Yes +-- [a] No Yes Yes Yes +-- @ + +-- $representation_types +-- A /source type/ is a type that is a separate type as far as the type checker is +-- concerned, but which has a more low-level representation as far as Core-to-Core +-- passes and the rest of the back end is concerned. Notably, 'PredTy's are removed +-- from the representation type while they do exist in the source types. +-- +-- You don't normally have to worry about this, as the utility functions in +-- this module will automatically convert a source into a representation type +-- if they are spotted, to the best of it's abilities. If you don't want this +-- to happen, use the equivalent functions from the "TcType" module. +\end{code} %************************************************************************ %* * @@ -143,71 +221,57 @@ import Data.Maybe ( isJust ) %* * %************************************************************************ -In Core, we "look through" non-recursive newtypes and PredTypes. - \begin{code} {-# INLINE coreView #-} coreView :: Type -> Maybe Type --- Strips off the *top layer only* of a type to give +-- ^ In Core, we \"look through\" non-recursive newtypes and 'PredTypes': this +-- function tries to obtain a different view of the supplied type given this +-- +-- Strips off the /top layer only/ of a type to give -- its underlying representation type. -- Returns Nothing if there is nothing to look through. -- --- In the case of newtypes, it returns --- *either* a vanilla TyConApp (recursive newtype, or non-saturated) --- *or* the newtype representation (otherwise), meaning the --- type written in the RHS of the newtype decl, --- which may itself be a newtype --- --- Example: newtype R = MkR S --- newtype S = MkS T --- newtype T = MkT (T -> T) --- expandNewTcApp on R gives Just S --- on S gives Just T --- on T gives Nothing (no expansion) - -- By being non-recursive and inlined, this case analysis gets efficiently -- joined onto the case analysis that the caller is already doing -coreView (NoteTy _ ty) = Just ty -coreView (PredTy p) - | isEqPred p = Nothing - | otherwise = Just (predTypeRep p) +coreView (PredTy p) = Just (predTypeRep p) coreView (TyConApp tc tys) | Just (tenv, rhs, tys') <- coreExpandTyCon_maybe tc tys = Just (mkAppTys (substTy (mkTopTvSubst tenv) rhs) tys') -- Its important to use mkAppTys, rather than (foldl AppTy), -- because the function part might well return a -- partially-applied type constructor; indeed, usually will! -coreView ty = Nothing - +coreView _ = Nothing ----------------------------------------------- {-# INLINE tcView #-} tcView :: Type -> Maybe Type --- Same, but for the type checker, which just looks through synonyms -tcView (NoteTy _ ty) = Just ty +-- ^ Similar to 'coreView', but for the type checker, which just looks through synonyms tcView (TyConApp tc tys) | Just (tenv, rhs, tys') <- tcExpandTyCon_maybe tc tys = Just (mkAppTys (substTy (mkTopTvSubst tenv) rhs) tys') -tcView ty = Nothing - ------------------------------------------------ -rttiView :: Type -> Type --- Same, but for the RTTI system, which cannot deal with predicates nor polymorphism -rttiView (ForAllTy _ ty) = rttiView ty -rttiView (NoteTy _ ty) = rttiView ty -rttiView (FunTy PredTy{} ty) = rttiView ty -rttiView (FunTy NoteTy{} ty) = rttiView ty -rttiView ty@TyConApp{} | Just ty' <- coreView ty - = rttiView ty' -rttiView (TyConApp tc tys) = mkTyConApp tc (map rttiView tys) -rttiView ty = ty +tcView _ = Nothing ----------------------------------------------- -{-# INLINE kindView #-} -kindView :: Kind -> Maybe Kind --- C.f. coreView, tcView --- For the moment, we don't even handle synonyms in kinds -kindView (NoteTy _ k) = Just k -kindView other = Nothing +expandTypeSynonyms :: Type -> Type +-- ^ Expand out all type synonyms. Actually, it'd suffice to expand out +-- just the ones that discard type variables (e.g. type Funny a = Int) +-- But we don't know which those are currently, so we just expand all. +expandTypeSynonyms ty + = go ty + where + go (TyConApp tc tys) + | Just (tenv, rhs, tys') <- tcExpandTyCon_maybe tc tys + = go (mkAppTys (substTy (mkTopTvSubst tenv) rhs) tys') + | otherwise + = TyConApp tc (map go tys) + go (TyVarTy tv) = TyVarTy tv + go (AppTy t1 t2) = AppTy (go t1) (go t2) + go (FunTy t1 t2) = FunTy (go t1) (go t2) + go (ForAllTy tv t) = ForAllTy tv (go t) + go (PredTy p) = PredTy (go_pred p) + + go_pred (ClassP c ts) = ClassP c (map go ts) + go_pred (IParam ip t) = IParam ip (go t) + go_pred (EqPred t1 t2) = EqPred (go t1) (go t2) \end{code} @@ -222,12 +286,8 @@ kindView other = Nothing TyVarTy ~~~~~~~ \begin{code} -mkTyVarTy :: TyVar -> Type -mkTyVarTy = TyVarTy - -mkTyVarTys :: [TyVar] -> [Type] -mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy - +-- | Attempts to obtain the type variable underlying a 'Type', and panics with the +-- given message if this is not a type variable type. See also 'getTyVar_maybe' getTyVar :: String -> Type -> TyVar getTyVar msg ty = case getTyVar_maybe ty of Just tv -> tv @@ -236,10 +296,11 @@ getTyVar msg ty = case getTyVar_maybe ty of isTyVarTy :: Type -> Bool isTyVarTy ty = isJust (getTyVar_maybe ty) +-- | Attempts to obtain the type variable underlying a 'Type' getTyVar_maybe :: Type -> Maybe TyVar getTyVar_maybe ty | Just ty' <- coreView ty = getTyVar_maybe ty' getTyVar_maybe (TyVarTy tv) = Just tv -getTyVar_maybe other = Nothing +getTyVar_maybe _ = Nothing \end{code} @@ -252,12 +313,13 @@ invariant that a TyConApp is always visibly so. mkAppTy maintains the invariant: use it. \begin{code} +-- | Applies a type to another, as in e.g. @k a@ +mkAppTy :: Type -> Type -> Type mkAppTy orig_ty1 orig_ty2 = mk_app orig_ty1 where - mk_app (NoteTy _ ty1) = mk_app ty1 mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ [orig_ty2]) - mk_app ty1 = AppTy orig_ty1 orig_ty2 + mk_app _ = AppTy orig_ty1 orig_ty2 -- Note that the TyConApp could be an -- under-saturated type synonym. GHC allows that; e.g. -- type Foo k = k a -> k a @@ -277,50 +339,57 @@ mkAppTys orig_ty1 [] = orig_ty1 mkAppTys orig_ty1 orig_tys2 = mk_app orig_ty1 where - mk_app (NoteTy _ ty1) = mk_app ty1 mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ orig_tys2) -- mkTyConApp: see notes with mkAppTy - mk_app ty1 = foldl AppTy orig_ty1 orig_tys2 + mk_app _ = foldl AppTy orig_ty1 orig_tys2 ------------- splitAppTy_maybe :: Type -> Maybe (Type, Type) +-- ^ Attempt to take a type application apart, whether it is a +-- function, type constructor, or plain type application. Note +-- that type family applications are NEVER unsaturated by this! splitAppTy_maybe ty | Just ty' <- coreView ty = splitAppTy_maybe ty' splitAppTy_maybe ty = repSplitAppTy_maybe ty ------------- repSplitAppTy_maybe :: Type -> Maybe (Type,Type) --- Does the AppTy split, but assumes that any view stuff is already done +-- ^ Does the AppTy split as in 'splitAppTy_maybe', but assumes that +-- any Core view stuff is already done repSplitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [ty1], ty2) repSplitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2) repSplitAppTy_maybe (TyConApp tc tys) - | not (isOpenSynTyCon tc) || length tys > tyConArity tc - = case snocView tys of -- never create unsaturated type family apps - Just (tys', ty') -> Just (TyConApp tc tys', ty') - Nothing -> Nothing + | isDecomposableTyCon tc || tys `lengthExceeds` tyConArity tc + , Just (tys', ty') <- snocView tys + = Just (TyConApp tc tys', ty') -- Never create unsaturated type family apps! repSplitAppTy_maybe _other = Nothing ------------- splitAppTy :: Type -> (Type, Type) +-- ^ Attempts to take a type application apart, as in 'splitAppTy_maybe', +-- and panics if this is not possible splitAppTy ty = case splitAppTy_maybe ty of Just pr -> pr Nothing -> panic "splitAppTy" ------------- splitAppTys :: Type -> (Type, [Type]) +-- ^ Recursively splits a type as far as is possible, leaving a residual +-- type being applied to and the type arguments applied to it. Never fails, +-- even if that means returning an empty list of type applications. splitAppTys ty = split ty ty [] where split orig_ty ty args | Just ty' <- coreView ty = split orig_ty ty' args - split orig_ty (AppTy ty arg) args = split ty ty (arg:args) - split orig_ty (TyConApp tc tc_args) args + split _ (AppTy ty arg) args = split ty ty (arg:args) + split _ (TyConApp tc tc_args) args = let -- keep type families saturated - n | isOpenSynTyCon tc = tyConArity tc - | otherwise = 0 - (tc_args1, tc_args2) = splitAt n tc_args + n | isDecomposableTyCon tc = 0 + | otherwise = tyConArity tc + (tc_args1, tc_args2) = splitAt n tc_args in (TyConApp tc tc_args1, tc_args2 ++ args) - split orig_ty (FunTy ty1 ty2) args = ASSERT( null args ) + split _ (FunTy ty1 ty2) args = ASSERT( null args ) (TyConApp funTyCon [], [ty1,ty2]) - split orig_ty ty args = (orig_ty, args) + split orig_ty _ args = (orig_ty, args) \end{code} @@ -331,7 +400,7 @@ splitAppTys ty = split ty ty [] \begin{code} mkFunTy :: Type -> Type -> Type -mkFunTy (PredTy (EqPred ty1 ty2)) res = mkForAllTy (mkWildCoVar (PredTy (EqPred ty1 ty2))) res +-- ^ Creates a function type from the given argument and result type mkFunTy arg res = FunTy arg res mkFunTys :: [Type] -> Type -> Type @@ -341,105 +410,96 @@ isFunTy :: Type -> Bool isFunTy ty = isJust (splitFunTy_maybe ty) splitFunTy :: Type -> (Type, Type) +-- ^ Attempts to extract the argument and result types from a type, and +-- panics if that is not possible. See also 'splitFunTy_maybe' splitFunTy ty | Just ty' <- coreView ty = splitFunTy ty' splitFunTy (FunTy arg res) = (arg, res) splitFunTy other = pprPanic "splitFunTy" (ppr other) splitFunTy_maybe :: Type -> Maybe (Type, Type) +-- ^ Attempts to extract the argument and result types from a type splitFunTy_maybe ty | Just ty' <- coreView ty = splitFunTy_maybe ty' splitFunTy_maybe (FunTy arg res) = Just (arg, res) -splitFunTy_maybe other = Nothing +splitFunTy_maybe _ = Nothing splitFunTys :: Type -> ([Type], Type) splitFunTys ty = split [] ty ty where split args orig_ty ty | Just ty' <- coreView ty = split args orig_ty ty' - split args orig_ty (FunTy arg res) = split (arg:args) res res - split args orig_ty ty = (reverse args, orig_ty) + split args _ (FunTy arg res) = split (arg:args) res res + split args orig_ty _ = (reverse args, orig_ty) splitFunTysN :: Int -> Type -> ([Type], Type) --- Split off exactly n arg tys +-- ^ 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) }} -zipFunTys :: Outputable a => [a] -> Type -> ([(a,Type)], Type) +-- | Splits off argument types from the given type and associating +-- them with the things in the input list from left to right. The +-- final result type is returned, along with the resulting pairs of +-- objects and types, albeit with the list of pairs in reverse order. +-- Panics if there are not enough argument types for the input list. +zipFunTys :: Outputable a => [a] -> Type -> ([(a, Type)], Type) zipFunTys orig_xs orig_ty = split [] orig_xs orig_ty orig_ty where - split acc [] nty ty = (reverse acc, nty) + split acc [] nty _ = (reverse acc, nty) split acc xs nty ty | Just ty' <- coreView ty = split acc xs nty ty' - split acc (x:xs) nty (FunTy arg res) = split ((x,arg):acc) xs res res - split acc (x:xs) nty ty = pprPanic "zipFunTys" (ppr orig_xs <+> ppr orig_ty) + split acc (x:xs) _ (FunTy arg res) = split ((x,arg):acc) xs res res + split _ _ _ _ = pprPanic "zipFunTys" (ppr orig_xs <+> ppr orig_ty) funResultTy :: Type -> Type +-- ^ Extract the function result type and panic if that is not possible funResultTy ty | Just ty' <- coreView ty = funResultTy ty' -funResultTy (FunTy arg res) = res -funResultTy ty = pprPanic "funResultTy" (ppr ty) +funResultTy (FunTy _arg res) = res +funResultTy ty = pprPanic "funResultTy" (ppr ty) funArgTy :: Type -> Type +-- ^ Extract the function argument type and panic if that is not possible funArgTy ty | Just ty' <- coreView ty = funArgTy ty' -funArgTy (FunTy arg res) = arg -funArgTy ty = pprPanic "funArgTy" (ppr ty) +funArgTy (FunTy arg _res) = arg +funArgTy ty = pprPanic "funArgTy" (ppr ty) \end{code} - --------------------------------------------------------------------- TyConApp ~~~~~~~~ -@mkTyConApp@ is a key function, because it builds a TyConApp, FunTy or PredTy, -as apppropriate. \begin{code} -mkTyConApp :: TyCon -> [Type] -> Type -mkTyConApp tycon tys - | isFunTyCon tycon, [ty1,ty2] <- tys - = FunTy ty1 ty2 - - | otherwise - = TyConApp tycon tys - -mkTyConTy :: TyCon -> Type -mkTyConTy tycon = mkTyConApp tycon [] - -- splitTyConApp "looks through" synonyms, because they don't -- mean a distinct type, but all other type-constructor applications -- including functions are returned as Just .. +-- | The same as @fst . splitTyConApp@ tyConAppTyCon :: Type -> TyCon tyConAppTyCon ty = fst (splitTyConApp ty) +-- | The same as @snd . splitTyConApp@ tyConAppArgs :: Type -> [Type] tyConAppArgs ty = snd (splitTyConApp ty) +-- | Attempts to tease a type apart into a type constructor and the application +-- of a number of arguments to that constructor. Panics if that is not possible. +-- See also 'splitTyConApp_maybe' splitTyConApp :: Type -> (TyCon, [Type]) splitTyConApp ty = case splitTyConApp_maybe ty of Just stuff -> stuff Nothing -> pprPanic "splitTyConApp" (ppr ty) +-- | Attempts to tease a type apart into a type constructor and the application +-- of a number of arguments to that constructor splitTyConApp_maybe :: Type -> Maybe (TyCon, [Type]) splitTyConApp_maybe ty | Just ty' <- coreView ty = splitTyConApp_maybe ty' splitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys) splitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res]) -splitTyConApp_maybe other = Nothing - --- Sometimes we do NOT want to look throught a newtype. When case matching --- on a newtype we want a convenient way to access the arguments of a newty --- constructor so as to properly form a coercion. -splitNewTyConApp :: Type -> (TyCon, [Type]) -splitNewTyConApp ty = case splitNewTyConApp_maybe ty of - Just stuff -> stuff - Nothing -> pprPanic "splitNewTyConApp" (ppr ty) -splitNewTyConApp_maybe :: Type -> Maybe (TyCon, [Type]) -splitNewTyConApp_maybe ty | Just ty' <- tcView ty = splitNewTyConApp_maybe ty' -splitNewTyConApp_maybe (TyConApp tc tys) = Just (tc, tys) -splitNewTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res]) -splitNewTyConApp_maybe other = Nothing +splitTyConApp_maybe _ = Nothing newTyConInstRhs :: TyCon -> [Type] -> Type --- Unwrap one 'layer' of newtype --- Use the eta'd version if possible +-- ^ Unwrap one 'layer' of newtype on a type constructor and its arguments, using an +-- eta-reduced version of the @newtype@ if possible newTyConInstRhs tycon tys = ASSERT2( equalLength tvs tys1, ppr tycon $$ ppr tys $$ ppr tvs ) mkAppTys (substTyWith tvs tys1 ty) tys2 @@ -468,42 +528,88 @@ The reason is that we then get better (shorter) type signatures in interfaces. Notably this plays a role in tcTySigs in TcBinds.lhs. +Note [Expanding newtypes] +~~~~~~~~~~~~~~~~~~~~~~~~~ +When expanding a type to expose a data-type constructor, we need to be +careful about newtypes, lest we fall into an infinite loop. Here are +the key examples: + + newtype Id x = MkId x + newtype Fix f = MkFix (f (Fix f)) + newtype T = MkT (T -> T) + + Type Expansion + -------------------------- + T T -> T + Fix Maybe Maybe (Fix Maybe) + Id (Id Int) Int + Fix Id NO NO NO + +Notice that we can expand T, even though it's recursive. +And we can expand Id (Id Int), even though the Id shows up +twice at the outer level. + +So, when expanding, we keep track of when we've seen a recursive +newtype at outermost level; and bale out if we see it again. + + Representation types ~~~~~~~~~~~~~~~~~~~~ -repType looks through - (a) for-alls, and - (b) synonyms - (c) predicates - (d) usage annotations - (e) all newtypes, including recursive ones, but not newtype families -It's useful in the back end. \begin{code} +-- | Looks through: +-- +-- 1. For-alls +-- 2. Synonyms +-- 3. Predicates +-- 4. All newtypes, including recursive ones, but not newtype families +-- +-- It's useful in the back end of the compiler. repType :: Type -> Type -- Only applied to types of kind *; hence tycons are saturated -repType ty | Just ty' <- coreView ty = repType ty' -repType (ForAllTy _ ty) = repType ty -repType (TyConApp tc tys) +repType ty + = go [] ty + where + go :: [TyCon] -> Type -> Type + go rec_nts (ForAllTy _ ty) -- Look through foralls + = go rec_nts ty + + go rec_nts (PredTy p) -- Expand predicates + = go rec_nts (predTypeRep p) + + go rec_nts (TyConApp tc tys) -- Expand newtypes and synonyms + | Just (tenv, rhs, tys') <- coreExpandTyCon_maybe tc tys + = go rec_nts (mkAppTys (substTy (mkTopTvSubst tenv) rhs) tys') + + | Just (rec_nts', ty') <- carefullySplitNewType_maybe rec_nts tc tys + = go rec_nts' ty' + + go _ ty = ty + + +carefullySplitNewType_maybe :: [TyCon] -> TyCon -> [Type] -> Maybe ([TyCon],Type) +-- Return the representation of a newtype, unless +-- we've seen it already: see Note [Expanding newtypes] +carefullySplitNewType_maybe rec_nts tc tys | isNewTyCon tc - , (tvs, rep_ty) <- newTyConRep tc - = -- Recursive newtypes are opaque to coreView - -- but we must expand them here. Sure to - -- be saturated because repType is only applied - -- to types of kind * - ASSERT( tys `lengthIs` tyConArity tc ) - repType (substTyWith tvs tys rep_ty) + , not (tc `elem` rec_nts) = Just (rec_nts', newTyConInstRhs tc tys) + | otherwise = Nothing + where + rec_nts' | isRecursiveTyCon tc = tc:rec_nts + | otherwise = rec_nts -repType ty = ty -- ToDo: this could be moved to the code generator, using splitTyConApp instead -- of inspecting the type directly. + +-- | Discovers the primitive representation of a more abstract 'Type' typePrimRep :: Type -> PrimRep typePrimRep ty = case repType ty of TyConApp tc _ -> tyConPrimRep tc FunTy _ _ -> PtrRep AppTy _ _ -> PtrRep -- See note below TyVarTy _ -> PtrRep - other -> pprPanic "typePrimRep" (ppr ty) + _ -> pprPanic "typePrimRep" (ppr ty) -- Types of the form 'f a' must be of kind *, not *#, so -- we are guaranteed that they are represented by pointers. -- The reason is that f must have kind *->*, not *->*#, because @@ -519,16 +625,18 @@ typePrimRep ty = case repType ty of \begin{code} mkForAllTy :: TyVar -> Type -> Type mkForAllTy tyvar ty - = mkForAllTys [tyvar] ty + = ForAllTy tyvar ty +-- | Wraps foralls over the type using the provided 'TyVar's from left to right mkForAllTys :: [TyVar] -> Type -> Type mkForAllTys tyvars ty = foldr ForAllTy ty tyvars isForAllTy :: Type -> Bool -isForAllTy (NoteTy _ ty) = isForAllTy ty isForAllTy (ForAllTy _ _) = True -isForAllTy other_ty = False +isForAllTy _ = False +-- | Attempts to take a forall type apart, returning the bound type variable +-- and the remainder of the type splitForAllTy_maybe :: Type -> Maybe (TyVar, Type) splitForAllTy_maybe ty = splitFAT_m ty where @@ -536,13 +644,17 @@ splitForAllTy_maybe ty = splitFAT_m ty splitFAT_m (ForAllTy tyvar ty) = Just(tyvar, ty) splitFAT_m _ = Nothing +-- | Attempts to take a forall type apart, returning all the immediate such bound +-- type variables and the remainder of the type. Always suceeds, even if that means +-- returning an empty list of 'TyVar's splitForAllTys :: Type -> ([TyVar], Type) splitForAllTys ty = split ty ty [] where split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs - split orig_ty (ForAllTy tv ty) tvs = split ty ty (tv:tvs) - split orig_ty t tvs = (reverse tvs, orig_ty) + split _ (ForAllTy tv ty) tvs = split ty ty (tv:tvs) + split orig_ty _ tvs = (reverse tvs, orig_ty) +-- | Equivalent to @snd . splitForAllTys@ dropForAlls :: Type -> Type dropForAlls ty = snd (splitForAllTys ty) \end{code} @@ -551,41 +663,52 @@ dropForAlls ty = snd (splitForAllTys ty) applyTy, applyTys ~~~~~~~~~~~~~~~~~ -Instantiate a for-all type with one or more type arguments. -Used when we have a polymorphic function applied to type args: - f t1 t2 -Then we use (applyTys type-of-f [t1,t2]) to compute the type of -the expression. \begin{code} +-- | Instantiate a forall type with one or more type arguments. +-- Used when we have a polymorphic function applied to type args: +-- +-- > f t1 t2 +-- +-- We use @applyTys type-of-f [t1,t2]@ to compute the type of the expression. +-- Panics if no application is possible. applyTy :: Type -> Type -> Type applyTy ty arg | Just ty' <- coreView ty = applyTy ty' arg applyTy (ForAllTy tv ty) arg = substTyWith [tv] [arg] ty -applyTy other arg = panic "applyTy" +applyTy _ _ = panic "applyTy" applyTys :: Type -> [Type] -> Type --- This function is interesting because --- a) the function may have more for-alls than there are args --- b) less obviously, it may have fewer for-alls --- For case (b) think of --- applyTys (forall a.a) [forall b.b, Int] +-- ^ This function is interesting because: +-- +-- 1. The function may have more for-alls than there are args +-- +-- 2. Less obviously, it may have fewer for-alls +-- +-- For case 2. think of: +-- +-- > applyTys (forall a.a) [forall b.b, Int] +-- -- This really can happen, via dressing up polymorphic types with newtype -- clothing. Here's an example: --- newtype R = R (forall a. a->a) --- foo = case undefined :: R of --- R f -> f () +-- +-- > newtype R = R (forall a. a->a) +-- > foo = case undefined :: R of +-- > R f -> f () + +applyTys ty args = applyTysD empty ty args -applyTys orig_fun_ty [] = orig_fun_ty -applyTys orig_fun_ty arg_tys +applyTysD :: SDoc -> Type -> [Type] -> Type -- Debug version +applyTysD _ orig_fun_ty [] = orig_fun_ty +applyTysD doc orig_fun_ty arg_tys | n_tvs == n_args -- The vastly common case = substTyWith tvs arg_tys rho_ty | n_tvs > n_args -- Too many for-alls = substTyWith (take n_args tvs) arg_tys (mkForAllTys (drop n_args tvs) rho_ty) | otherwise -- Too many type args - = ASSERT2( n_tvs > 0, ppr orig_fun_ty ) -- Zero case gives infnite loop! - applyTys (substTyWith tvs (take n_tvs arg_tys) rho_ty) - (drop n_tvs arg_tys) + = ASSERT2( n_tvs > 0, doc $$ ppr orig_fun_ty ) -- Zero case gives infnite loop! + applyTysD doc (substTyWith tvs (take n_tvs arg_tys) rho_ty) + (drop n_tvs arg_tys) where (tvs, rho_ty) = splitForAllTys orig_fun_ty n_tvs = length tvs @@ -595,16 +718,32 @@ applyTys orig_fun_ty arg_tys %************************************************************************ %* * -\subsection{Source types} + Pred %* * %************************************************************************ -A "source type" is a type that is a separate type as far as the type checker is -concerned, but which has low-level representation as far as the back end is concerned. +Polymorphic functions over Pred -Source types are always lifted. +\begin{code} +allPred :: (a -> Bool) -> Pred a -> Bool +allPred p (ClassP _ ts) = all p ts +allPred p (IParam _ t) = p t +allPred p (EqPred t1 t2) = p t1 && p t2 + +isClassPred :: Pred a -> Bool +isClassPred (ClassP {}) = True +isClassPred _ = False + +isEqPred :: Pred a -> Bool +isEqPred (EqPred {}) = True +isEqPred _ = False + +isIPPred :: Pred a -> Bool +isIPPred (IParam {}) = True +isIPPred _ = False +\end{code} -The key function is predTypeRep which gives the representation of a source type: +Make PredTypes \begin{code} mkPredTy :: PredType -> Type @@ -614,109 +753,128 @@ mkPredTys :: ThetaType -> [Type] mkPredTys preds = map PredTy preds predTypeRep :: PredType -> Type --- Convert a PredType to its "representation type"; --- the post-type-checking type used by all the Core passes of GHC. --- Unwraps only the outermost level; for example, the result might --- be a newtype application +-- ^ Convert a 'PredType' to its representation type. However, it unwraps +-- only the outermost level; for example, the result might be a newtype application predTypeRep (IParam _ ty) = ty predTypeRep (ClassP clas tys) = mkTyConApp (classTyCon clas) tys - -- Result might be a newtype application, but the consumer will - -- look through that too if necessary -predTypeRep (EqPred ty1 ty2) = pprPanic "predTypeRep" (ppr (EqPred ty1 ty2)) +predTypeRep (EqPred ty1 ty2) = mkTyConApp eqPredPrimTyCon [ty1,ty2] -mkFamilyTyConApp :: TyCon -> [Type] -> Type --- Given a family instance TyCon and its arg types, return the --- corresponding family type. E.g. --- data family T a --- data instance T (Maybe b) = MkT b -- Instance tycon :RTL --- Then --- mkFamilyTyConApp :RTL Int = T (Maybe Int) -mkFamilyTyConApp tc tys - | Just (fam_tc, fam_tys) <- tyConFamInst_maybe tc - , let fam_subst = zipTopTvSubst (tyConTyVars tc) tys - = mkTyConApp fam_tc (substTys fam_subst fam_tys) - | otherwise - = mkTyConApp tc tys +splitPredTy_maybe :: Type -> Maybe PredType +-- Returns Just for predicates only +splitPredTy_maybe ty | Just ty' <- tcView ty = splitPredTy_maybe ty' +splitPredTy_maybe (PredTy p) = Just p +splitPredTy_maybe _ = Nothing --- Pretty prints a tycon, using the family instance in case of a --- representation tycon. For example --- e.g. data T [a] = ... --- In that case we want to print `T [a]', where T is the family TyCon -pprSourceTyCon tycon - | Just (fam_tc, tys) <- tyConFamInst_maybe tycon - = ppr $ fam_tc `TyConApp` tys -- can't be FunTyCon - | otherwise - = ppr tycon +isPredTy :: Type -> Bool +isPredTy ty = isJust (splitPredTy_maybe ty) \end{code} +--------------------- Equality types --------------------------------- +\begin{code} +isReflPredTy :: Type -> Bool +isReflPredTy ty = case splitPredTy_maybe ty of + Just (EqPred ty1 ty2) -> ty1 `eqType` ty2 + _ -> False + +splitEqPredTy_maybe :: Type -> Maybe (Type,Type) +splitEqPredTy_maybe ty = case splitPredTy_maybe ty of + Just (EqPred ty1 ty2) -> Just (ty1,ty2) + _ -> Nothing + +isEqPredTy :: Type -> Bool +isEqPredTy ty = case splitPredTy_maybe ty of + Just (EqPred {}) -> True + _ -> False + +-- | Creates a type equality predicate +mkEqPred :: (a, a) -> Pred a +mkEqPred (ty1, ty2) = EqPred ty1 ty2 +\end{code} -%************************************************************************ -%* * -\subsection{Kinds and free variables} -%* * -%************************************************************************ +--------------------- Dictionary types --------------------------------- +\begin{code} +mkClassPred :: Class -> [Type] -> PredType +mkClassPred clas tys = ClassP clas tys + +isDictTy :: Type -> Bool +isDictTy ty = case splitPredTy_maybe ty of + Just p -> isClassPred p + Nothing -> False + +isTyVarClassPred :: PredType -> Bool +isTyVarClassPred (ClassP _ tys) = all isTyVarTy tys +isTyVarClassPred _ = False + +getClassPredTys_maybe :: PredType -> Maybe (Class, [Type]) +getClassPredTys_maybe (ClassP clas tys) = Just (clas, tys) +getClassPredTys_maybe _ = Nothing + +getClassPredTys :: PredType -> (Class, [Type]) +getClassPredTys (ClassP clas tys) = (clas, tys) +getClassPredTys _ = panic "getClassPredTys" + +mkDictTy :: Class -> [Type] -> Type +mkDictTy clas tys = mkPredTy (ClassP clas tys) + +isDictLikeTy :: Type -> Bool +-- Note [Dictionary-like types] +isDictLikeTy ty | Just ty' <- tcView ty = isDictTy ty' +isDictLikeTy (PredTy p) = isClassPred p +isDictLikeTy (TyConApp tc tys) + | isTupleTyCon tc = all isDictLikeTy tys +isDictLikeTy _ = False +\end{code} + +Note [Dictionary-like types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Being "dictionary-like" means either a dictionary type or a tuple thereof. +In GHC 6.10 we build implication constraints which construct such tuples, +and if we land up with a binding + t :: (C [a], Eq [a]) + t = blah +then we want to treat t as cheap under "-fdicts-cheap" for example. +(Implication constraints are normally inlined, but sadly not if the +occurrence is itself inside an INLINE function! Until we revise the +handling of implication constraints, that is.) This turned out to +be important in getting good arities in DPH code. Example: + + class C a + class D a where { foo :: a -> a } + instance C a => D (Maybe a) where { foo x = x } + + bar :: (C a, C b) => a -> b -> (Maybe a, Maybe b) + {-# INLINE bar #-} + bar x y = (foo (Just x), foo (Just y)) + +Then 'bar' should jolly well have arity 4 (two dicts, two args), but +we ended up with something like + bar = __inline_me__ (\d1,d2. let t :: (D (Maybe a), D (Maybe b)) = ... + in \x,y. ) + +This is all a bit ad-hoc; eg it relies on knowing that implication +constraints build tuples. + +--------------------- Implicit parameters --------------------------------- ---------------------------------------------------------------------- - Finding the kind of a type - ~~~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} -typeKind :: Type -> Kind -typeKind (TyConApp tycon tys) = ASSERT( not (isCoercionTyCon tycon) ) - -- We should be looking for the coercion kind, - -- not the type kind - foldr (\_ k -> kindFunResult k) (tyConKind tycon) tys -typeKind (NoteTy _ ty) = typeKind ty -typeKind (PredTy pred) = predKind pred -typeKind (AppTy fun arg) = kindFunResult (typeKind fun) -typeKind (ForAllTy tv ty) = typeKind ty -typeKind (TyVarTy tyvar) = tyVarKind tyvar -typeKind (FunTy arg res) - -- Hack alert. The kind of (Int -> Int#) is liftedTypeKind (*), - -- not unliftedTypKind (#) - -- The only things that can be after a function arrow are - -- (a) types (of kind openTypeKind or its sub-kinds) - -- (b) kinds (of super-kind TY) (e.g. * -> (* -> *)) - | isTySuperKind k = k - | otherwise = ASSERT( isSubOpenTypeKind k) liftedTypeKind - where - k = typeKind res - -predKind :: PredType -> Kind -predKind (EqPred {}) = coSuperKind -- A coercion kind! -predKind (ClassP {}) = liftedTypeKind -- Class and implicitPredicates are -predKind (IParam {}) = liftedTypeKind -- always represented by lifted types +mkIPPred :: IPName Name -> Type -> PredType +mkIPPred ip ty = IParam ip ty \end{code} +%************************************************************************ +%* * + Size +%* * +%************************************************************************ ---------------------------------------------------------------------- - Free variables of a type - ~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} -tyVarsOfType :: Type -> TyVarSet --- NB: for type synonyms tyVarsOfType does *not* expand the synonym -tyVarsOfType (TyVarTy tv) = unitVarSet tv -tyVarsOfType (TyConApp tycon tys) = tyVarsOfTypes tys -tyVarsOfType (NoteTy (FTVNote tvs) ty2) = tvs -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 - -tyVarsOfTypes :: [Type] -> TyVarSet -tyVarsOfTypes tys = foldr (unionVarSet.tyVarsOfType) emptyVarSet tys - -tyVarsOfPred :: PredType -> TyVarSet -tyVarsOfPred (IParam _ ty) = tyVarsOfType ty -tyVarsOfPred (ClassP _ tys) = tyVarsOfTypes tys -tyVarsOfPred (EqPred ty1 ty2) = tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2 - -tyVarsOfTheta :: ThetaType -> TyVarSet -tyVarsOfTheta = foldr (unionVarSet . tyVarsOfPred) emptyVarSet - --- Add a Note with the free tyvars to the top of the type -addFreeTyVars :: Type -> Type -addFreeTyVars ty@(NoteTy (FTVNote _) _) = ty -addFreeTyVars ty = NoteTy (FTVNote (tyVarsOfType ty)) ty +typeSize :: Type -> Int +typeSize (TyVarTy _) = 1 +typeSize (AppTy t1 t2) = typeSize t1 + typeSize t2 +typeSize (FunTy t1 t2) = typeSize t1 + typeSize t2 +typeSize (PredTy p) = predSize typeSize p +typeSize (ForAllTy _ t) = 1 + typeSize t +typeSize (TyConApp _ ts) = 1 + sum (map typeSize ts) \end{code} @@ -726,117 +884,58 @@ addFreeTyVars ty = NoteTy (FTVNote (tyVarsOfType ty)) ty %* * %************************************************************************ -Type family instances occuring in a type after expanding synonyms. - \begin{code} +-- | Finds type family instances occuring in a type after expanding synonyms. tyFamInsts :: Type -> [(TyCon, [Type])] 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 tyFamInsts (ForAllTy _ ty) = tyFamInsts ty -\end{code} - - -%************************************************************************ -%* * -\subsection{TidyType} -%* * -%************************************************************************ - -tidyTy 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. - -\begin{code} -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 tyvars 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 -tidyOpenTyVar env@(tidy_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@(tidy_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 (NoteTy note ty) = (NoteTy $! (go_note note)) $! (go ty) - 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 - - go_note note@(FTVNote ftvs) = note -- No need to tidy the free tyvars - -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} +tyFamInsts (PredTy pty) = predFamInsts pty +-- | Finds type family instances occuring in a predicate type after expanding +-- synonyms. +predFamInsts :: PredType -> [(TyCon, [Type])] +predFamInsts (ClassP _cla tys) = concat (map tyFamInsts tys) +predFamInsts (IParam _ ty) = tyFamInsts ty +predFamInsts (EqPred ty1 ty2) = tyFamInsts ty1 ++ tyFamInsts ty2 -@tidyOpenType@ grabs the free type variables, tidies them -and then uses @tidyType@ to work over the type itself - -\begin{code} -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 - -tidyTopType :: Type -> Type -tidyTopType ty = tidyType emptyTidyEnv ty -\end{code} - -\begin{code} - -tidyKind :: TidyEnv -> Kind -> (TidyEnv, Kind) -tidyKind env k = tidyOpenType env k +mkFamilyTyConApp :: TyCon -> [Type] -> Type +-- ^ Given a family instance TyCon and its arg types, return the +-- corresponding family type. E.g: +-- +-- > data family T a +-- > data instance T (Maybe b) = MkT b +-- +-- Where the instance tycon is :RTL, so: +-- +-- > mkFamilyTyConApp :RTL Int = T (Maybe Int) +mkFamilyTyConApp tc tys + | Just (fam_tc, fam_tys) <- tyConFamInst_maybe tc + , let fam_subst = zipTopTvSubst (tyConTyVars tc) tys + = mkTyConApp fam_tc (substTys fam_subst fam_tys) + | otherwise + = mkTyConApp tc tys +-- | Pretty prints a 'TyCon', using the family instance in case of a +-- representation tycon. For example: +-- +-- > data T [a] = ... +-- +-- In that case we want to print @T [a]@, where @T@ is the family 'TyCon' +pprSourceTyCon :: TyCon -> SDoc +pprSourceTyCon tycon + | Just (fam_tc, tys) <- tyConFamInst_maybe tycon + = ppr $ fam_tc `TyConApp` tys -- can't be FunTyCon + | otherwise + = ppr tycon \end{code} - %************************************************************************ %* * \subsection{Liftedness} @@ -844,6 +943,7 @@ tidyKind env k = tidyOpenType env k %************************************************************************ \begin{code} +-- | See "Type#type_classification" for what an unlifted type is isUnLiftedType :: Type -> Bool -- isUnLiftedType returns True for forall'd unlifted types: -- x :: forall a. Int# @@ -852,16 +952,19 @@ isUnLiftedType :: Type -> Bool -- construct them isUnLiftedType ty | Just ty' <- coreView ty = isUnLiftedType ty' -isUnLiftedType (ForAllTy tv ty) = isUnLiftedType ty +isUnLiftedType (ForAllTy _ ty) = isUnLiftedType ty +isUnLiftedType (PredTy p) = isEqPred p isUnLiftedType (TyConApp tc _) = isUnLiftedTyCon tc -isUnLiftedType other = False +isUnLiftedType _ = False isUnboxedTupleType :: Type -> Bool isUnboxedTupleType ty = case splitTyConApp_maybe ty of - Just (tc, ty_args) -> isUnboxedTupleTyCon tc - other -> False + Just (tc, _ty_args) -> isUnboxedTupleTyCon tc + _ -> False --- Should only be applied to *types*; hence the assert +-- | See "Type#type_classification" for what an algebraic type is. +-- Should only be applied to /types/, as opposed to e.g. partially +-- saturated type constructors isAlgType :: Type -> Bool isAlgType ty = case splitTyConApp_maybe ty of @@ -869,52 +972,118 @@ isAlgType ty isAlgTyCon tc _other -> False --- Should only be applied to *types*; hence the assert +-- | See "Type#type_classification" for what an algebraic type is. +-- Should only be applied to /types/, as opposed to e.g. partially +-- saturated type constructors. Closed type constructors are those +-- with a fixed right hand side, as opposed to e.g. associated types 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} -@isStrictType@ computes whether an argument (or let RHS) should -be computed strictly or lazily, based only on its type. -Works just like isUnLiftedType, except that it has a special case -for dictionaries. Since it takes account of ClassP, you might think -this function should be in TcType, but isStrictType is used by DataCon, -which is below TcType in the hierarchy, so it's convenient to put it here. - \begin{code} +-- | Computes whether an argument (or let right hand side) should +-- be computed strictly or lazily, based only on its type. +-- Works just like 'isUnLiftedType', except that it has a special case +-- for dictionaries (i.e. does not work purely on representation types) + +-- Since it takes account of class 'PredType's, you might think +-- this function should be in 'TcType', but 'isStrictType' is used by 'DataCon', +-- which is below 'TcType' in the hierarchy, so it's convenient to put it here. +isStrictType :: Type -> Bool isStrictType (PredTy pred) = isStrictPred pred isStrictType ty | Just ty' <- coreView ty = isStrictType ty' -isStrictType (ForAllTy tv ty) = isStrictType ty +isStrictType (ForAllTy _ ty) = isStrictType ty isStrictType (TyConApp tc _) = isUnLiftedTyCon tc -isStrictType other = False +isStrictType _ = False +-- | We may be strict in dictionary types, but only if it +-- has more than one component. +-- +-- (Being strict in a single-component dictionary risks +-- poking the dictionary component, which is wrong.) +isStrictPred :: PredType -> Bool isStrictPred (ClassP clas _) = opt_DictsStrict && not (isNewTyCon (classTyCon clas)) -isStrictPred other = False - -- We may be strict in dictionary types, but only if it - -- has more than one component. - -- [Being strict in a single-component dictionary risks - -- poking the dictionary component, which is wrong.] +isStrictPred (EqPred {}) = True +isStrictPred (IParam {}) = False \end{code} \begin{code} isPrimitiveType :: Type -> Bool --- Returns types that are opaque to Haskell. +-- ^ Returns true of types that are opaque to Haskell. -- Most of these are unlifted, but now that we interact with .NET, we -- may have primtive (foreign-imported) types that are lifted isPrimitiveType ty = case splitTyConApp_maybe ty of Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc ) isPrimTyCon tc - other -> False + _ -> False \end{code} %************************************************************************ %* * -\subsection{Sequencing on types + The "exact" free variables of a type +%* * +%************************************************************************ + +Note [Silly type synonym] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + type T a = Int +What are the free tyvars of (T x)? Empty, of course! +Here's the example that Ralf Laemmel showed me: + foo :: (forall a. C u a -> C u a) -> u + mappend :: Monoid u => u -> u -> u + + bar :: Monoid u => u + bar = foo (\t -> t `mappend` t) +We have to generalise at the arg to f, and we don't +want to capture the constraint (Monad (C u a)) because +it appears to mention a. Pretty silly, but it was useful to him. + +exactTyVarsOfType is used by the type checker to figure out exactly +which type variables are mentioned in a type. It's also used in the +smart-app checking code --- see TcExpr.tcIdApp + +On the other hand, consider a *top-level* definition + f = (\x -> x) :: T a -> T a +If we don't abstract over 'a' it'll get fixed to GHC.Prim.Any, and then +if we have an application like (f "x") we get a confusing error message +involving Any. So the conclusion is this: when generalising + - at top level use tyVarsOfType + - in nested bindings use exactTyVarsOfType +See Trac #1813 for example. + +\begin{code} +exactTyVarsOfType :: Type -> TyVarSet +-- Find the free type variables (of any kind) +-- but *expand* type synonyms. See Note [Silly type synonym] above. +exactTyVarsOfType ty + = go ty + where + go ty | Just ty' <- tcView ty = go ty' -- This is the key line + go (TyVarTy tv) = unitVarSet tv + go (TyConApp _ tys) = exactTyVarsOfTypes tys + go (PredTy ty) = go_pred ty + go (FunTy arg res) = go arg `unionVarSet` go res + go (AppTy fun arg) = go fun `unionVarSet` go arg + go (ForAllTy tyvar ty) = delVarSet (go ty) tyvar + + go_pred (IParam _ ty) = go ty + go_pred (ClassP _ tys) = exactTyVarsOfTypes tys + go_pred (EqPred ty1 ty2) = go ty1 `unionVarSet` go ty2 + +exactTyVarsOfTypes :: [Type] -> TyVarSet +exactTyVarsOfTypes tys = foldr (unionVarSet . exactTyVarsOfType) emptyVarSet tys +\end{code} + + +%************************************************************************ +%* * +\subsection{Sequencing on types} %* * %************************************************************************ @@ -923,8 +1092,7 @@ seqType :: Type -> () seqType (TyVarTy tv) = tv `seq` () seqType (AppTy t1 t2) = seqType t1 `seq` seqType t2 seqType (FunTy t1 t2) = seqType t1 `seq` seqType t2 -seqType (NoteTy note t2) = seqNote note `seq` seqType t2 -seqType (PredTy p) = seqPred p +seqType (PredTy p) = seqPred seqType p seqType (TyConApp tc tys) = tc `seq` seqTypes tys seqType (ForAllTy tv ty) = tv `seq` seqType ty @@ -932,113 +1100,40 @@ seqTypes :: [Type] -> () seqTypes [] = () seqTypes (ty:tys) = seqType ty `seq` seqTypes tys -seqNote :: TyNote -> () -seqNote (FTVNote set) = sizeUniqSet set `seq` () - -seqPred :: PredType -> () -seqPred (ClassP c tys) = c `seq` seqTypes tys -seqPred (IParam n ty) = n `seq` seqType ty -seqPred (EqPred ty1 ty2) = seqType ty1 `seq` seqType ty2 +seqPred :: (a -> ()) -> Pred a -> () +seqPred seqt (ClassP c tys) = c `seq` foldr (seq . seqt) () tys +seqPred seqt (IParam n ty) = n `seq` seqt ty +seqPred seqt (EqPred ty1 ty2) = seqt ty1 `seq` seqt ty2 \end{code} %************************************************************************ %* * - Equality for Core types + Comparision for types (We don't use instances so that we know where it happens) %* * %************************************************************************ -Note that eqType works right even for partial applications of newtypes. -See Note [Newtype eta] in TyCon.lhs - \begin{code} -coreEqType :: Type -> Type -> Bool -coreEqType t1 t2 - = eq rn_env t1 t2 - where - rn_env = mkRnEnv2 (mkInScopeSet (tyVarsOfType t1 `unionVarSet` tyVarsOfType t2)) - - eq env (TyVarTy tv1) (TyVarTy tv2) = rnOccL env tv1 == rnOccR env tv2 - eq env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = eq (rnBndr2 env tv1 tv2) t1 t2 - eq env (AppTy s1 t1) (AppTy s2 t2) = eq env s1 s2 && eq env t1 t2 - eq env (FunTy s1 t1) (FunTy s2 t2) = eq env s1 s2 && eq env t1 t2 - eq env (TyConApp tc1 tys1) (TyConApp tc2 tys2) - | tc1 == tc2, all2 (eq env) tys1 tys2 = True - -- The lengths should be equal because - -- the two types have the same kind - -- NB: if the type constructors differ that does not - -- necessarily mean that the types aren't equal - -- (synonyms, newtypes) - -- Even if the type constructors are the same, but the arguments - -- differ, the two types could be the same (e.g. if the arg is just - -- ignored in the RHS). In both these cases we fall through to an - -- attempt to expand one side or the other. - - -- Now deal with newtypes, synonyms, pred-tys - eq env t1 t2 | Just t1' <- coreView t1 = eq env t1' t2 - | Just t2' <- coreView t2 = eq env t1 t2' - - -- Fall through case; not equal! - eq env t1 t2 = False -\end{code} - - -%************************************************************************ -%* * - Comparision for source types - (We don't use instances so that we know where it happens) -%* * -%************************************************************************ - -Note that - tcEqType, tcCmpType -do *not* look through newtypes, PredTypes - -\begin{code} -tcEqType :: Type -> Type -> Bool -tcEqType t1 t2 = isEqual $ cmpType t1 t2 - -tcEqTypes :: [Type] -> [Type] -> Bool -tcEqTypes tys1 tys2 = isEqual $ cmpTypes tys1 tys2 - -tcCmpType :: Type -> Type -> Ordering -tcCmpType t1 t2 = cmpType t1 t2 - -tcCmpTypes :: [Type] -> [Type] -> Ordering -tcCmpTypes tys1 tys2 = cmpTypes tys1 tys2 +eqKind :: Kind -> Kind -> Bool +eqKind = eqType -tcEqPred :: PredType -> PredType -> Bool -tcEqPred p1 p2 = isEqual $ cmpPred p1 p2 +eqType :: Type -> Type -> Bool +-- ^ Type equality on source types. Does not look through @newtypes@ or +-- 'PredType's, but it does look through type synonyms. +eqType t1 t2 = isEqual $ cmpType t1 t2 -tcCmpPred :: PredType -> PredType -> Ordering -tcCmpPred p1 p2 = cmpPred p1 p2 +eqTypeX :: RnEnv2 -> Type -> Type -> Bool +eqTypeX env t1 t2 = isEqual $ cmpTypeX env t1 t2 -tcEqTypeX :: RnEnv2 -> Type -> Type -> Bool -tcEqTypeX env t1 t2 = isEqual $ cmpTypeX env t1 t2 -\end{code} +eqTypes :: [Type] -> [Type] -> Bool +eqTypes tys1 tys2 = isEqual $ cmpTypes tys1 tys2 -Checks whether the second argument is a subterm of the first. (We don't care -about binders, as we are only interested in syntactic subterms.) +eqPred :: PredType -> PredType -> Bool +eqPred p1 p2 = isEqual $ cmpPred p1 p2 -\begin{code} -tcPartOfType :: Type -> Type -> Bool -tcPartOfType t1 t2 - | tcEqType t1 t2 = True -tcPartOfType t1 t2 - | Just t2' <- tcView t2 = tcPartOfType t1 t2' -tcPartOfType _ (TyVarTy _) = False -tcPartOfType t1 (ForAllTy _ t2) = tcPartOfType t1 t2 -tcPartOfType t1 (AppTy s2 t2) = tcPartOfType t1 s2 || tcPartOfType t1 t2 -tcPartOfType t1 (FunTy s2 t2) = tcPartOfType t1 s2 || tcPartOfType t1 t2 -tcPartOfType t1 (PredTy p2) = tcPartOfPred t1 p2 -tcPartOfType t1 (TyConApp _ ts) = any (tcPartOfType t1) ts -tcPartOfType t1 (NoteTy _ t2) = tcPartOfType t1 t2 - -tcPartOfPred :: Type -> PredType -> Bool -tcPartOfPred t1 (IParam _ t2) = tcPartOfType t1 t2 -tcPartOfPred t1 (ClassP _ ts) = any (tcPartOfType t1) ts -tcPartOfPred t1 (EqPred s2 t2) = tcPartOfType t1 s2 || tcPartOfType t1 t2 +eqPredX :: RnEnv2 -> PredType -> PredType -> Bool +eqPredX env p1 p2 = isEqual $ cmpPredX env p1 p2 \end{code} Now here comes the real worker @@ -1060,8 +1155,13 @@ cmpPred p1 p2 = cmpPredX rn_env p1 p2 rn_env = mkRnEnv2 (mkInScopeSet (tyVarsOfPred p1 `unionVarSet` tyVarsOfPred p2)) cmpTypeX :: RnEnv2 -> Type -> Type -> Ordering -- Main workhorse -cmpTypeX env t1 t2 | Just t1' <- tcView t1 = cmpTypeX env t1' t2 - | Just t2' <- tcView t2 = cmpTypeX env t1 t2' +cmpTypeX env t1 t2 | Just t1' <- coreView t1 = cmpTypeX env t1' t2 + | Just t2' <- coreView t2 = cmpTypeX env t1 t2' +-- We expand predicate types, because in Core-land we have +-- lots of definitions like +-- fOrdBool :: Ord Bool +-- fOrdBool = D:Ord .. .. .. +-- So the RHS has a data type cmpTypeX env (TyVarTy tv1) (TyVarTy tv2) = rnOccL env tv1 `compare` rnOccR env tv2 cmpTypeX env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = cmpTypeX (rnBndr2 env tv1 tv2) t1 t2 @@ -1069,33 +1169,32 @@ cmpTypeX env (AppTy s1 t1) (AppTy s2 t2) = cmpTypeX env s1 s2 `thenC cmpTypeX env (FunTy s1 t1) (FunTy s2 t2) = cmpTypeX env s1 s2 `thenCmp` cmpTypeX env t1 t2 cmpTypeX env (PredTy p1) (PredTy p2) = cmpPredX env p1 p2 cmpTypeX env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 `compare` tc2) `thenCmp` cmpTypesX env tys1 tys2 -cmpTypeX env t1 (NoteTy _ t2) = cmpTypeX env t1 t2 -- Deal with the rest: TyVarTy < AppTy < FunTy < TyConApp < ForAllTy < PredTy -cmpTypeX env (AppTy _ _) (TyVarTy _) = GT - -cmpTypeX env (FunTy _ _) (TyVarTy _) = GT -cmpTypeX env (FunTy _ _) (AppTy _ _) = GT - -cmpTypeX env (TyConApp _ _) (TyVarTy _) = GT -cmpTypeX env (TyConApp _ _) (AppTy _ _) = GT -cmpTypeX env (TyConApp _ _) (FunTy _ _) = GT - -cmpTypeX env (ForAllTy _ _) (TyVarTy _) = GT -cmpTypeX env (ForAllTy _ _) (AppTy _ _) = GT -cmpTypeX env (ForAllTy _ _) (FunTy _ _) = GT -cmpTypeX env (ForAllTy _ _) (TyConApp _ _) = GT +cmpTypeX _ (AppTy _ _) (TyVarTy _) = GT + +cmpTypeX _ (FunTy _ _) (TyVarTy _) = GT +cmpTypeX _ (FunTy _ _) (AppTy _ _) = GT -cmpTypeX env (PredTy _) t2 = GT +cmpTypeX _ (TyConApp _ _) (TyVarTy _) = GT +cmpTypeX _ (TyConApp _ _) (AppTy _ _) = GT +cmpTypeX _ (TyConApp _ _) (FunTy _ _) = GT -cmpTypeX env _ _ = LT +cmpTypeX _ (ForAllTy _ _) (TyVarTy _) = GT +cmpTypeX _ (ForAllTy _ _) (AppTy _ _) = GT +cmpTypeX _ (ForAllTy _ _) (FunTy _ _) = GT +cmpTypeX _ (ForAllTy _ _) (TyConApp _ _) = GT + +cmpTypeX _ (PredTy _) _ = GT + +cmpTypeX _ _ _ = LT ------------- cmpTypesX :: RnEnv2 -> [Type] -> [Type] -> Ordering -cmpTypesX env [] [] = EQ +cmpTypesX _ [] [] = EQ cmpTypesX env (t1:tys1) (t2:tys2) = cmpTypeX env t1 t2 `thenCmp` cmpTypesX env tys1 tys2 -cmpTypesX env [] tys = LT -cmpTypesX env ty [] = GT +cmpTypesX _ [] _ = LT +cmpTypesX _ _ [] = GT ------------- cmpPredX :: RnEnv2 -> PredType -> PredType -> Ordering @@ -1109,18 +1208,18 @@ cmpPredX env (ClassP c1 tys1) (ClassP c2 tys2) = (c1 `compare` c2) `thenCmp` (cm cmpPredX env (EqPred ty1 ty2) (EqPred ty1' ty2') = (cmpTypeX env ty1 ty1') `thenCmp` (cmpTypeX env ty2 ty2') -- Constructor order: IParam < ClassP < EqPred -cmpPredX env (IParam {}) _ = LT -cmpPredX env (ClassP {}) (IParam {}) = GT -cmpPredX env (ClassP {}) (EqPred {}) = LT -cmpPredX env (EqPred {}) _ = GT +cmpPredX _ (IParam {}) _ = LT +cmpPredX _ (ClassP {}) (IParam {}) = GT +cmpPredX _ (ClassP {}) (EqPred {}) = LT +cmpPredX _ (EqPred {}) _ = GT \end{code} PredTypes are used as a FM key in TcSimplify, so we take the easy path and make them an instance of Ord \begin{code} -instance Eq PredType where { (==) = tcEqPred } -instance Ord PredType where { compare = tcCmpPred } +instance Eq PredType where { (==) = eqPred } +instance Ord PredType where { compare = cmpPred } \end{code} @@ -1131,80 +1230,13 @@ instance Ord PredType where { compare = tcCmpPred } %************************************************************************ \begin{code} -data TvSubst - = TvSubst InScopeSet -- The in-scope type variables - TvSubstEnv -- The substitution itself - -- See Note [Apply Once] - -- and Note [Extending the TvSubstEnv] - -{- ---------------------------------------------------------- - -Note [Apply Once] -~~~~~~~~~~~~~~~~~ -We use TvSubsts to instantiate things, and we might instantiate - forall a b. ty -\with the types - [a, b], or [b, a]. -So the substition might go [a->b, b->a]. A similar situation arises in Core -when we find a beta redex like - (/\ a /\ b -> e) b a -Then we also end up with a substition that permutes type variables. Other -variations happen to; for example [a -> (a, b)]. - - *************************************************** - *** So a TvSubst must be applied precisely once *** - *************************************************** - -A TvSubst is not idempotent, but, unlike the non-idempotent substitution -we use during unifications, it must not be repeatedly applied. - -Note [Extending the TvSubst] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The following invariant should hold of a TvSubst - - The in-scope set is needed *only* to - guide the generation of fresh uniques - - In particular, the *kind* of the type variables in - the in-scope set is not relevant - -This invariant allows a short-cut when the TvSubstEnv is empty: -if the TvSubstEnv is empty --- i.e. (isEmptyTvSubt subst) holds --- -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 - -This invariant has several crucial consequences: - -* In substTyVarBndr, we need extend the TvSubstEnv - - if the unique has changed - - or if the kind has changed - -* In substTyVar, we do not need to consult the in-scope set; - the TvSubstEnv is enough - -* In substTy, substTheta, we can short-circuit when the TvSubstEnv is empty - - --------------------------------------------------------------- -} - - -type TvSubstEnv = TyVarEnv Type - -- A TvSubstEnv is used both inside a TvSubst (with the apply-once - -- invariant discussed in Note [Apply Once]), and also independently - -- in the middle of matching, and unification (see Types.Unify) - -- So you have to look at the context to know if it's idempotent or - -- apply-once or whatever emptyTvSubstEnv :: TvSubstEnv emptyTvSubstEnv = emptyVarEnv composeTvSubst :: InScopeSet -> TvSubstEnv -> TvSubstEnv -> TvSubstEnv --- (compose env1 env2)(x) is env1(env2(x)); i.e. apply env2 then env1 --- It assumes that both are idempotent --- Typically, env1 is the refinement to a base substitution env2 +-- ^ @(compose env1 env2)(x)@ is @env1(env2(x))@; i.e. apply @env2@ then @env1@. +-- It assumes that both are idempotent. +-- Typically, @env1@ is the refinement to a base substitution @env2@ composeTvSubst in_scope env1 env2 = env1 `plusVarEnv` mapVarEnv (substTy subst1) env2 -- First apply env1 to the range of env2 @@ -1214,11 +1246,12 @@ composeTvSubst in_scope env1 env2 where subst1 = TvSubst in_scope env1 -emptyTvSubst = TvSubst emptyInScopeSet emptyVarEnv +emptyTvSubst :: TvSubst +emptyTvSubst = TvSubst emptyInScopeSet emptyTvSubstEnv isEmptyTvSubst :: TvSubst -> Bool -- See Note [Extending the TvSubstEnv] -isEmptyTvSubst (TvSubst _ env) = isEmptyVarEnv env +isEmptyTvSubst (TvSubst _ tenv) = isEmptyVarEnv tenv mkTvSubst :: InScopeSet -> TvSubstEnv -> TvSubst mkTvSubst = TvSubst @@ -1232,64 +1265,88 @@ getTvInScope (TvSubst in_scope _) = in_scope isInScope :: Var -> TvSubst -> Bool isInScope v (TvSubst in_scope _) = v `elemInScopeSet` in_scope -notElemTvSubst :: TyVar -> TvSubst -> Bool -notElemTvSubst tv (TvSubst _ env) = not (tv `elemVarEnv` env) +notElemTvSubst :: TyCoVar -> TvSubst -> Bool +notElemTvSubst v (TvSubst _ tenv) = not (v `elemVarEnv` tenv) setTvSubstEnv :: TvSubst -> TvSubstEnv -> TvSubst -setTvSubstEnv (TvSubst in_scope _) env = TvSubst in_scope env +setTvSubstEnv (TvSubst in_scope _) tenv = TvSubst in_scope tenv + +zapTvSubstEnv :: TvSubst -> TvSubst +zapTvSubstEnv (TvSubst in_scope _) = TvSubst in_scope emptyVarEnv -extendTvInScope :: TvSubst -> [Var] -> TvSubst -extendTvInScope (TvSubst in_scope env) vars = TvSubst (extendInScopeSetList in_scope vars) env +extendTvInScope :: TvSubst -> Var -> TvSubst +extendTvInScope (TvSubst in_scope tenv) var = TvSubst (extendInScopeSet in_scope var) tenv + +extendTvInScopeList :: TvSubst -> [Var] -> TvSubst +extendTvInScopeList (TvSubst in_scope tenv) vars = TvSubst (extendInScopeSetList in_scope vars) tenv extendTvSubst :: TvSubst -> TyVar -> Type -> TvSubst -extendTvSubst (TvSubst in_scope env) tv ty = TvSubst in_scope (extendVarEnv env tv ty) +extendTvSubst (TvSubst in_scope tenv) tv ty = TvSubst in_scope (extendVarEnv tenv tv ty) extendTvSubstList :: TvSubst -> [TyVar] -> [Type] -> TvSubst -extendTvSubstList (TvSubst in_scope env) tvs tys - = TvSubst in_scope (extendVarEnvList env (tvs `zip` tys)) +extendTvSubstList (TvSubst in_scope tenv) tvs tys + = TvSubst in_scope (extendVarEnvList tenv (tvs `zip` tys)) + +unionTvSubst :: TvSubst -> TvSubst -> TvSubst +-- Works when the ranges are disjoint +unionTvSubst (TvSubst in_scope1 tenv1) (TvSubst in_scope2 tenv2) + = ASSERT( not (tenv1 `intersectsVarEnv` tenv2) ) + TvSubst (in_scope1 `unionInScope` in_scope2) + (tenv1 `plusVarEnv` tenv2) -- 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 +-- Note [Generating the in-scope set for a substitution] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- If we want to substitute [a -> ty1, b -> ty2] I used to +-- think it was enough to generate an in-scope set that includes +-- fv(ty1,ty2). But that's not enough; we really should also take the +-- free vars of the type we are substituting into! Example: +-- (forall b. (a,b,x)) [a -> List b] +-- Then if we use the in-scope set {b}, there is a danger we will rename +-- the forall'd variable to 'x' by mistake, getting this: +-- (forall x. (List b, x, x) +-- Urk! This means looking at all the calls to mkOpenTvSubst.... + + +-- | Generates the in-scope set for the 'TvSubst' from the types in the incoming +-- environment, hence "open" mkOpenTvSubst :: TvSubstEnv -> TvSubst -mkOpenTvSubst env = TvSubst (mkInScopeSet (tyVarsOfTypes (varEnvElts env))) env +mkOpenTvSubst tenv = TvSubst (mkInScopeSet (tyVarsOfTypes (varEnvElts tenv))) tenv +-- | Generates the in-scope set for the 'TvSubst' from the types in the incoming +-- environment, hence "open" zipOpenTvSubst :: [TyVar] -> [Type] -> TvSubst zipOpenTvSubst tyvars tys -#ifdef DEBUG - | length tyvars /= length tys + | debugIsOn && (length tyvars /= length tys) = pprTrace "zipOpenTvSubst" (ppr tyvars $$ ppr tys) emptyTvSubst | otherwise -#endif = TvSubst (mkInScopeSet (tyVarsOfTypes tys)) (zipTyEnv tyvars tys) --- mkTopTvSubst is called when doing top-level substitutions. --- Here we expect that the free vars of the range of the --- substitution will be empty. +-- | Called when doing top-level substitutions. Here we expect that the +-- free vars of the range of the substitution will be empty. mkTopTvSubst :: [(TyVar, Type)] -> TvSubst mkTopTvSubst prs = TvSubst emptyInScopeSet (mkVarEnv prs) zipTopTvSubst :: [TyVar] -> [Type] -> TvSubst zipTopTvSubst tyvars tys -#ifdef DEBUG - | length tyvars /= length tys + | debugIsOn && (length tyvars /= length tys) = pprTrace "zipTopTvSubst" (ppr tyvars $$ ppr tys) emptyTvSubst | otherwise -#endif = TvSubst emptyInScopeSet (zipTyEnv tyvars tys) zipTyEnv :: [TyVar] -> [Type] -> TvSubstEnv zipTyEnv tyvars tys -#ifdef DEBUG - | length tyvars /= length tys - = pprTrace "mkTopTvSubst" (ppr tyvars $$ ppr tys) emptyVarEnv + | debugIsOn && (length tyvars /= length tys) + = pprTrace "zipTyEnv" (ppr tyvars $$ ppr tys) emptyVarEnv | otherwise -#endif = zip_ty_env tyvars tys emptyVarEnv -- Later substitutions in the list over-ride earlier ones, -- but there should be no loops +zip_ty_env :: [TyVar] -> [Type] -> TvSubstEnv -> TvSubstEnv zip_ty_env [] [] env = env zip_ty_env (tv:tvs) (ty:tys) env = zip_ty_env tvs tys (extendVarEnv env tv ty) -- There used to be a special case for when @@ -1308,10 +1365,10 @@ zip_ty_env tvs tys env = pprTrace "Var/Type length mismatch: " (ppr -- zip_ty_env _ _ env = env instance Outputable TvSubst where - ppr (TvSubst ins env) - = brackets $ sep[ ptext SLIT("TvSubst"), - nest 2 (ptext SLIT("In scope:") <+> ppr ins), - nest 2 (ptext SLIT("Env:") <+> ppr env) ] + ppr (TvSubst ins tenv) + = brackets $ sep[ ptext (sLit "TvSubst"), + nest 2 (ptext (sLit "In scope:") <+> ppr ins), + nest 2 (ptext (sLit "Type env:") <+> ppr tenv) ] \end{code} %************************************************************************ @@ -1321,29 +1378,42 @@ instance Outputable TvSubst where %************************************************************************ \begin{code} +-- | Type substitution making use of an 'TvSubst' that +-- is assumed to be open, see 'zipOpenTvSubst' substTyWith :: [TyVar] -> [Type] -> Type -> Type substTyWith tvs tys = ASSERT( length tvs == length tys ) substTy (zipOpenTvSubst tvs tys) +-- | Type substitution making use of an 'TvSubst' that +-- is assumed to be open, see 'zipOpenTvSubst' +substTysWith :: [TyVar] -> [Type] -> [Type] -> [Type] +substTysWith tvs tys = ASSERT( length tvs == length tys ) + substTys (zipOpenTvSubst tvs tys) + +-- | Substitute within a 'Type' substTy :: TvSubst -> Type -> Type substTy subst ty | isEmptyTvSubst subst = ty | otherwise = subst_ty subst ty +-- | Substitute within several 'Type's substTys :: TvSubst -> [Type] -> [Type] substTys subst tys | isEmptyTvSubst subst = tys | otherwise = map (subst_ty subst) tys +-- | Substitute within a 'ThetaType' substTheta :: TvSubst -> ThetaType -> ThetaType substTheta subst theta | isEmptyTvSubst subst = theta | otherwise = map (substPred subst) theta +-- | Substitute within a 'PredType' substPred :: TvSubst -> PredType -> PredType substPred subst (IParam n ty) = IParam n (subst_ty subst ty) substPred subst (ClassP clas tys) = ClassP clas (map (subst_ty subst) tys) substPred subst (EqPred ty1 ty2) = EqPred (subst_ty subst ty1) (subst_ty subst ty2) -deShadowTy :: TyVarSet -> Type -> Type -- Remove any nested binders mentioning tvs +-- | Remove any nested binders mentioning the 'TyVar's in the 'TyVarSet' +deShadowTy :: TyVarSet -> Type -> Type deShadowTy tvs ty = subst_ty (mkTvSubst in_scope emptyTvSubstEnv) ty where @@ -1357,46 +1427,50 @@ subst_ty :: TvSubst -> Type -> Type subst_ty subst ty = go ty where - go (TyVarTy tv) = substTyVar subst tv - go (TyConApp tc tys) = let args = map go tys - in args `seqList` TyConApp tc args - - go (PredTy p) = PredTy $! (substPred subst p) + go (TyVarTy tv) = substTyVar subst tv + go (TyConApp tc tys) = let args = map go tys + in args `seqList` TyConApp tc args - go (NoteTy (FTVNote _) ty2) = go ty2 -- Discard the free tyvar note + go (PredTy p) = PredTy $! (substPred subst p) - go (FunTy arg res) = (FunTy $! (go arg)) $! (go res) - go (AppTy fun arg) = mkAppTy (go fun) $! (go arg) - -- The mkAppTy smart constructor is important - -- we might be replacing (a Int), represented with App - -- by [Int], represented with TyConApp - go (ForAllTy tv ty) = case substTyVarBndr subst tv of - (subst', tv') -> ForAllTy tv' $! (subst_ty subst' ty) + go (FunTy arg res) = (FunTy $! (go arg)) $! (go res) + go (AppTy fun arg) = mkAppTy (go fun) $! (go arg) + -- The mkAppTy smart constructor is important + -- we might be replacing (a Int), represented with App + -- by [Int], represented with TyConApp + go (ForAllTy tv ty) = case substTyVarBndr subst tv of + (subst', tv') -> + ForAllTy tv' $! (subst_ty subst' ty) substTyVar :: TvSubst -> TyVar -> Type -substTyVar subst@(TvSubst in_scope env) tv - = case lookupTyVar subst tv of { - Nothing -> TyVarTy tv; - Just ty -> ty -- See Note [Apply Once] - } +substTyVar (TvSubst _ tenv) tv + | Just ty <- lookupVarEnv tenv tv = ty -- See Note [Apply Once] + | otherwise = ASSERT( isTyVar tv ) TyVarTy tv + -- We do not require that the tyvar is in scope + -- Reason: we do quite a bit of (substTyWith [tv] [ty] tau) + -- and it's a nuisance to bring all the free vars of tau into + -- scope --- and then force that thunk at every tyvar + -- Instead we have an ASSERT in substTyVarBndr to check for capture substTyVars :: TvSubst -> [TyVar] -> [Type] substTyVars subst tvs = map (substTyVar subst) tvs lookupTyVar :: TvSubst -> TyVar -> Maybe Type -- See Note [Extending the TvSubst] -lookupTyVar (TvSubst in_scope env) tv = lookupVarEnv env tv +lookupTyVar (TvSubst _ tenv) tv = lookupVarEnv tenv tv -substTyVarBndr :: TvSubst -> TyVar -> (TvSubst, TyVar) -substTyVarBndr subst@(TvSubst in_scope env) old_var - = (TvSubst (in_scope `extendInScopeSet` new_var) new_env, new_var) +substTyVarBndr :: TvSubst -> TyVar -> (TvSubst, TyVar) +substTyVarBndr subst@(TvSubst in_scope tenv) old_var + = ASSERT2( _no_capture, ppr old_var $$ ppr subst ) + (TvSubst (in_scope `extendInScopeSet` new_var) new_env, new_var) where - is_co_var = isCoVar old_var + new_env | no_change = delVarEnv tenv old_var + | otherwise = extendVarEnv tenv old_var (TyVarTy new_var) - new_env | no_change = delVarEnv env old_var - | otherwise = extendVarEnv env old_var (TyVarTy new_var) + _no_capture = not (new_var `elemVarSet` tyVarsOfTypes (varEnvElts tenv)) + -- Check that we are not capturing something in the substitution - no_change = new_var == old_var && not is_co_var + no_change = new_var == old_var -- no_change means that the new_var is identical in -- all respects to the old_var (same unique, same kind) -- See Note [Extending the TvSubst] @@ -1407,14 +1481,8 @@ substTyVarBndr subst@(TvSubst in_scope env) old_var -- (\x.e) with id_subst = [x |-> e'] -- Here we must simply zap the substitution for x - new_var = uniqAway in_scope subst_old_var + new_var = uniqAway in_scope old_var -- The uniqAway part makes sure the new variable is not already in scope - - subst_old_var -- subst_old_var is old_var with the substitution applied to its kind - -- It's only worth doing the substitution for coercions, - -- becuase only they can have free type variables - | is_co_var = setTyVarKind old_var (substTy subst (tyVarKind old_var)) - | otherwise = old_var \end{code} ---------------------------------------------------- @@ -1422,28 +1490,35 @@ substTyVarBndr subst@(TvSubst in_scope env) old_var Kinds ~~~~~ -There's a little subtyping at the kind level: - - ? - / \ - / \ - ?? (#) - / \ - * # - -where * [LiftedTypeKind] means boxed type - # [UnliftedTypeKind] means unboxed type - (#) [UbxTupleKind] means unboxed tuple - ?? [ArgTypeKind] is the lub of *,# - ? [OpenTypeKind] means any type at all - -In particular: - - error :: forall a:?. String -> a - (->) :: ?? -> ? -> * - (\(x::t) -> ...) Here t::?? (i.e. not unboxed tuple) \begin{code} +-- $kind_subtyping +-- #kind_subtyping# +-- There's a little subtyping at the kind level: +-- +-- @ +-- ? +-- \/ \ +-- \/ \ +-- ?? (\#) +-- \/ \ +-- \* \# +-- . +-- Where: \* [LiftedTypeKind] means boxed type +-- \# [UnliftedTypeKind] means unboxed type +-- (\#) [UbxTupleKind] means unboxed tuple +-- ?? [ArgTypeKind] is the lub of {\*, \#} +-- ? [OpenTypeKind] means any type at all +-- @ +-- +-- In particular: +-- +-- > error :: forall a:?. String -> a +-- > (->) :: ?? -> ? -> \* +-- > (\\(x::t) -> ...) +-- +-- Where in the last example @t :: ??@ (i.e. is not an unboxed tuple) + type KindVar = TyVar -- invariant: KindVar will always be a -- TcTyVar with details MetaTv TauTv ... -- kind var constructors and functions are in TcType @@ -1474,121 +1549,3 @@ When unifying two internal type variables, we collect their kind constraints by finding the GLB of the two. Since the partial order is a tree, they only have a glb if one is a sub-kind of the other. In that case, we bind the less-informative one to the more informative one. Neat, eh? - - -\begin{code} - -\end{code} - -%************************************************************************ -%* * - Functions over Kinds -%* * -%************************************************************************ - -\begin{code} -kindFunResult :: Kind -> Kind -kindFunResult k = funResultTy k - -splitKindFunTys :: Kind -> ([Kind],Kind) -splitKindFunTys k = splitFunTys k - -splitKindFunTysN :: Int -> Kind -> ([Kind],Kind) -splitKindFunTysN k = splitFunTysN k - -isUbxTupleKind, isOpenTypeKind, isArgTypeKind, isUnliftedTypeKind :: Kind -> Bool - -isOpenTypeKindCon tc = tyConUnique tc == openTypeKindTyConKey - -isOpenTypeKind (TyConApp tc _) = isOpenTypeKindCon tc -isOpenTypeKind other = False - -isUbxTupleKindCon tc = tyConUnique tc == ubxTupleKindTyConKey - -isUbxTupleKind (TyConApp tc _) = isUbxTupleKindCon tc -isUbxTupleKind other = False - -isArgTypeKindCon tc = tyConUnique tc == argTypeKindTyConKey - -isArgTypeKind (TyConApp tc _) = isArgTypeKindCon tc -isArgTypeKind other = False - -isUnliftedTypeKindCon tc = tyConUnique tc == unliftedTypeKindTyConKey - -isUnliftedTypeKind (TyConApp tc _) = isUnliftedTypeKindCon tc -isUnliftedTypeKind other = False - -isSubOpenTypeKind :: Kind -> Bool --- True of any sub-kind of OpenTypeKind (i.e. anything except arrow) -isSubOpenTypeKind (FunTy k1 k2) = ASSERT2 ( isKind k1, text "isSubOpenTypeKind" <+> ppr k1 <+> text "::" <+> ppr (typeKind k1) ) - ASSERT2 ( isKind k2, text "isSubOpenTypeKind" <+> ppr k2 <+> text "::" <+> ppr (typeKind k2) ) - False -isSubOpenTypeKind (TyConApp kc []) = ASSERT( isKind (TyConApp kc []) ) True -isSubOpenTypeKind other = ASSERT( isKind other ) False - -- This is a conservative answer - -- It matters in the call to isSubKind in - -- checkExpectedKind. - -isSubArgTypeKindCon kc - | isUnliftedTypeKindCon kc = True - | isLiftedTypeKindCon kc = True - | isArgTypeKindCon kc = True - | otherwise = False - -isSubArgTypeKind :: Kind -> Bool --- True of any sub-kind of ArgTypeKind -isSubArgTypeKind (TyConApp kc []) = isSubArgTypeKindCon kc -isSubArgTypeKind other = False - -isSuperKind :: Type -> Bool -isSuperKind (TyConApp (skc) []) = isSuperKindTyCon skc -isSuperKind other = False - -isKind :: Kind -> Bool -isKind k = isSuperKind (typeKind k) - -isSubKind :: Kind -> Kind -> Bool --- (k1 `isSubKind` k2) checks that k1 <: k2 -isSubKind (TyConApp kc1 []) (TyConApp kc2 []) = kc1 `isSubKindCon` kc2 -isSubKind (FunTy a1 r1) (FunTy a2 r2) = (a2 `isSubKind` a1) && (r1 `isSubKind` r2) -isSubKind (PredTy (EqPred ty1 ty2)) (PredTy (EqPred ty1' ty2')) - = ty1 `tcEqType` ty1' && ty2 `tcEqType` ty2' -isSubKind k1 k2 = False - -eqKind :: Kind -> Kind -> Bool -eqKind = tcEqType - -isSubKindCon :: TyCon -> TyCon -> Bool --- (kc1 `isSubKindCon` kc2) checks that kc1 <: kc2 -isSubKindCon kc1 kc2 - | isLiftedTypeKindCon kc1 && isLiftedTypeKindCon kc2 = True - | isUnliftedTypeKindCon kc1 && isUnliftedTypeKindCon kc2 = True - | isUbxTupleKindCon kc1 && isUbxTupleKindCon kc2 = True - | isOpenTypeKindCon kc2 = True - -- we already know kc1 is not a fun, its a TyCon - | isArgTypeKindCon kc2 && isSubArgTypeKindCon kc1 = True - | otherwise = False - -defaultKind :: Kind -> Kind --- Used when generalising: default kind '?' and '??' to '*' --- --- When we generalise, we make generic type variables whose kind is --- simple (* or *->* etc). So generic type variables (other than --- built-in constants like 'error') always have simple kinds. This is important; --- consider --- f x = True --- We want f to get type --- f :: forall (a::*). a -> Bool --- Not --- f :: forall (a::??). a -> Bool --- because that would allow a call like (f 3#) as well as (f True), ---and the calling conventions differ. This defaulting is done in TcMType.zonkTcTyVarBndr. -defaultKind k - | isSubOpenTypeKind k = liftedTypeKind - | isSubArgTypeKind k = liftedTypeKind - | otherwise = k - -isEqPred :: PredType -> Bool -isEqPred (EqPred _ _) = True -isEqPred other = False -\end{code}