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
-- $type_classification
-- $representation_types
- TyThing(..), Type, PredType(..), ThetaType,
+ TyThing(..), Type, Pred(..), PredType, ThetaType,
+ Var, TyVar, isTyVar,
-- ** Constructing and deconstructing types
mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe,
mkFunTy, mkFunTys, splitFunTy, splitFunTy_maybe,
splitFunTys, splitFunTysN,
- funResultTy, funArgTy, zipFunTys,
+ funResultTy, funArgTy, zipFunTys,
mkTyConApp, mkTyConTy,
tyConAppTyCon, tyConAppArgs,
-- (Type families)
tyFamInsts, predFamInsts,
- -- (Source types)
+ -- 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,
+ isTyVarTy, isFunTy, isPredTy,
+ isDictTy, isEqPredTy, isReflPredTy, splitPredTy_maybe, splitEqPredTy_maybe,
-- (Lifting and boxity)
isUnLiftedType, isUnboxedTupleType, isAlgType, isClosedAlgType,
-- $kind_subtyping
Kind, SimpleKind, KindVar,
- -- ** Deconstructing Kinds
- kindFunResult, splitKindFunTys, splitKindFunTysN, splitKindFunTy_maybe,
-
-- ** Common Kinds and SuperKinds
liftedTypeKind, unliftedTypeKind, openTypeKind,
argTypeKind, ubxTupleKind,
-
- tySuperKind, coSuperKind,
+ tySuperKind,
-- ** Common Kind type constructors
liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon,
argTypeKindTyCon, ubxTupleKindTyCon,
- -- ** Predicates on Kinds
- isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind,
- isUbxTupleKind, isArgTypeKind, isKind, isTySuperKind,
- isCoSuperKind, isSuperKind, isCoercionKind, isEqPred,
- mkArrowKind, mkArrowKinds,
-
- isSubArgTypeKind, isSubOpenTypeKind, isSubKind, defaultKind, eqKind,
- isSubKindCon,
-
-- * Type free variables
tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,
- typeKind, expandTypeSynonyms,
-
- -- * Tidying type related things up for printing
- tidyType, tidyTypes,
- tidyOpenType, tidyOpenTypes,
- tidyTyVarBndr, tidyFreeTyVars,
- tidyOpenTyVar, tidyOpenTyVars,
- tidyTopType, tidyPred,
- tidyKind,
+ exactTyVarsOfType, exactTyVarsOfTypes, expandTypeSynonyms,
+ typeSize,
-- * Type comparison
- coreEqType, tcEqType, tcEqTypes, tcCmpType, tcCmpTypes,
- tcEqPred, tcEqPredX, tcCmpPred, tcEqTypeX, tcPartOfType, tcPartOfPred,
+ eqType, eqTypeX, eqTypes, cmpType, cmpTypes,
+ eqPred, eqPredX, cmpPred, eqKind,
-- * Forcing evaluation of types
- seqType, seqTypes,
+ seqType, seqTypes, seqPred,
-- * Other views onto Types
- coreView, tcView, kindView,
+ coreView, tcView,
repType,
emptyTvSubstEnv, emptyTvSubst,
mkTvSubst, mkOpenTvSubst, zipOpenTvSubst, zipTopTvSubst, mkTopTvSubst, notElemTvSubst,
- getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope, extendTvInScopeList,
- extendTvSubst, extendTvSubstList, isInScope, composeTvSubst, zipTyEnv,
- isEmptyTvSubst,
+ 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,
+ substPred, substTyVar, substTyVars, substTyVarBndr,
+ deShadowTy, lookupTyVar,
-- * Pretty-printing
pprType, pprParendType, pprTypeApp, pprTyThingCategory, pprTyThing, pprForAll,
- pprPred, pprEqPred, pprTheta, pprThetaArrow, pprClassPred, pprKind, pprParendKind,
+ pprPred, pprPredTy, pprEqPred, pprTheta, pprThetaArrowTy, pprClassPred,
+ pprKind, pprParendKind,
pprSourceTyCon
) where
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 FastString
-import Data.List
import Data.Maybe ( isJust )
+
+infixr 3 `mkFunTy` -- Associates to the right
\end{code}
\begin{code}
-- its underlying representation type.
-- Returns Nothing if there is nothing to look through.
--
--- In the case of @newtype@s, it returns one of:
---
--- 1) A vanilla 'TyConApp' (recursive newtype, or non-saturated)
---
--- 2) The newtype representation (otherwise), meaning the
--- type written in the RHS of the newtype declaration,
--- which may itself be a newtype
---
--- For example, with:
---
--- > newtype R = MkR S
--- > newtype S = MkS T
--- > newtype T = MkT (T -> T)
---
--- 'expandNewTcApp' on:
---
--- * @R@ gives @Just S@
--- * @S@ gives @Just T@
--- * @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 (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),
coreView _ = Nothing
-
-----------------------------------------------
{-# INLINE tcView #-}
tcView :: Type -> Maybe Type
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)
-
------------------------------------------------
-{-# INLINE kindView #-}
-kindView :: Kind -> Maybe Kind
--- ^ Similar to 'coreView' or 'tcView', but works on 'Kind's
-
--- For the moment, we don't even handle synonyms in kinds
-kindView _ = Nothing
\end{code}
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
repSplitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [ty1], ty2)
repSplitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2)
repSplitAppTy_maybe (TyConApp tc tys)
- | isDecomposableTyCon 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)
\begin{code}
mkFunTy :: Type -> Type -> Type
-- ^ Creates a function type from the given argument and result type
-mkFunTy arg@(PredTy (EqPred {})) res = ForAllTy (mkWildCoVar arg) res
-mkFunTy arg res = FunTy arg res
+mkFunTy arg res = FunTy arg res
mkFunTys :: [Type] -> Type -> Type
mkFunTys tys ty = foldr mkFunTy ty tys
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) }}
~~~~~~~~
\begin{code}
--- | A key function: builds a 'TyConApp' or 'FunTy' as apppropriate to its arguments.
--- Applies its arguments to the constructor from left to right
-mkTyConApp :: TyCon -> [Type] -> Type
-mkTyConApp tycon tys
- | isFunTyCon tycon, [ty1,ty2] <- tys
- = FunTy ty1 ty2
-
- | otherwise
- = TyConApp tycon tys
-
--- | Create the plain type constructor type which has been applied to no type arguments at all.
-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 ..
= go [] ty
where
go :: [TyCon] -> Type -> Type
- go rec_nts ty | Just ty' <- coreView ty -- Expand synonyms
- = go rec_nts ty'
-
- go rec_nts (ForAllTy _ ty) -- Look through foralls
+ go rec_nts (ForAllTy _ ty) -- Look through foralls
= go rec_nts ty
- go rec_nts (TyConApp tc tys) -- Expand newtypes
+ 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'
%************************************************************************
%* *
-\subsection{Source types}
+ Pred
%* *
%************************************************************************
-Source types are always lifted.
+Polymorphic functions over Pred
+
+\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
-- 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
---
--- 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
+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:
---
--- > 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
+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. <blah>)
+
+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 (PredTy pred) = predKind pred
-typeKind (AppTy fun _) = kindFunResult (typeKind fun)
-typeKind (ForAllTy _ 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 _ 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
-
-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
+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}
| 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
predFamInsts (ClassP _cla tys) = concat (map tyFamInsts tys)
predFamInsts (IParam _ ty) = tyFamInsts ty
predFamInsts (EqPred ty1 ty2) = tyFamInsts ty1 ++ tyFamInsts ty2
-\end{code}
-
-%************************************************************************
-%* *
-\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
+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}
isUnLiftedType ty | Just ty' <- coreView ty = isUnLiftedType ty'
isUnLiftedType (ForAllTy _ ty) = isUnLiftedType ty
+isUnLiftedType (PredTy p) = isEqPred p
isUnLiftedType (TyConApp tc _) = isUnLiftedTyCon tc
isUnLiftedType _ = False
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}
-- poking the dictionary component, which is wrong.)
isStrictPred :: PredType -> Bool
isStrictPred (ClassP clas _) = opt_DictsStrict && not (isNewTyCon (classTyCon clas))
-isStrictPred _ = False
+isStrictPred (EqPred {}) = True
+isStrictPred (IParam {}) = False
\end{code}
\begin{code}
%************************************************************************
%* *
+ 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}
%* *
%************************************************************************
seqType (TyVarTy tv) = tv `seq` ()
seqType (AppTy t1 t2) = seqType t1 `seq` seqType t2
seqType (FunTy t1 t2) = seqType t1 `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
seqTypes [] = ()
seqTypes (ty:tys) = seqType ty `seq` seqTypes tys
-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}
--- | Type equality test for Core types (i.e. ignores predicate-types, synonyms etc.)
-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 _ _ _ = False
-\end{code}
-
-
-%************************************************************************
-%* *
- Comparision for source types
- (We don't use instances so that we know where it happens)
-%* *
-%************************************************************************
+eqKind :: Kind -> Kind -> Bool
+eqKind = eqType
-\begin{code}
-tcEqType :: Type -> Type -> Bool
+eqType :: Type -> Type -> Bool
-- ^ Type equality on source types. Does not look through @newtypes@ or
-- 'PredType's, but it does look through type synonyms.
-tcEqType t1 t2 = isEqual $ cmpType t1 t2
-
-tcEqTypes :: [Type] -> [Type] -> Bool
-tcEqTypes tys1 tys2 = isEqual $ cmpTypes tys1 tys2
+eqType t1 t2 = isEqual $ cmpType t1 t2
-tcCmpType :: Type -> Type -> Ordering
--- ^ Type ordering on source types. Does not look through @newtypes@ or
--- 'PredType's, but it does look through type synonyms.
-tcCmpType t1 t2 = cmpType t1 t2
+eqTypeX :: RnEnv2 -> Type -> Type -> Bool
+eqTypeX env t1 t2 = isEqual $ cmpTypeX env t1 t2
-tcCmpTypes :: [Type] -> [Type] -> Ordering
-tcCmpTypes tys1 tys2 = cmpTypes tys1 tys2
+eqTypes :: [Type] -> [Type] -> Bool
+eqTypes tys1 tys2 = isEqual $ cmpTypes tys1 tys2
-tcEqPred :: PredType -> PredType -> Bool
-tcEqPred p1 p2 = isEqual $ cmpPred p1 p2
+eqPred :: PredType -> PredType -> Bool
+eqPred p1 p2 = isEqual $ cmpPred p1 p2
-tcEqPredX :: RnEnv2 -> PredType -> PredType -> Bool
-tcEqPredX env p1 p2 = isEqual $ cmpPredX env p1 p2
-
-tcCmpPred :: PredType -> PredType -> Ordering
-tcCmpPred p1 p2 = cmpPred p1 p2
-
-tcEqTypeX :: RnEnv2 -> Type -> Type -> Bool
-tcEqTypeX env t1 t2 = isEqual $ cmpTypeX env t1 t2
-\end{code}
-
-\begin{code}
--- | 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.)
-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
-
-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
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
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}
%************************************************************************
\begin{code}
--- | Type substitution
---
--- #tvsubst_invariant#
--- The following invariants must hold of a 'TvSubst':
---
--- 1. The in-scope set is needed /only/ to
--- guide the generation of fresh uniques
---
--- 2. In particular, the /kind/ of the type variables in
--- the in-scope set is not relevant
---
--- 3. The substition is only applied ONCE! This is because
--- in general such application will not reached a fixed point.
-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]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-See #tvsubst_invariant# for the invariants that must hold.
-
-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
-
-
--------------------------------------------------------------- -}
-
--- | A substitition of 'Type's for 'TyVar's
-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
subst1 = TvSubst in_scope env1
emptyTvSubst :: TvSubst
-emptyTvSubst = TvSubst emptyInScopeSet emptyVarEnv
+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
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) var = TvSubst (extendInScopeSet in_scope var) env
+extendTvInScope (TvSubst in_scope tenv) var = TvSubst (extendInScopeSet in_scope var) tenv
extendTvInScopeList :: TvSubst -> [Var] -> TvSubst
-extendTvInScopeList (TvSubst in_scope env) vars = TvSubst (extendInScopeSetList in_scope vars) env
+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
-- | 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"
zipTyEnv :: [TyVar] -> [Type] -> TvSubstEnv
zipTyEnv tyvars tys
| debugIsOn && (length tyvars /= length tys)
- = pprTrace "mkTopTvSubst" (ppr tyvars $$ ppr tys) emptyVarEnv
+ = pprTrace "zipTyEnv" (ppr tyvars $$ ppr tys) emptyVarEnv
| otherwise
= zip_ty_env tyvars tys emptyVarEnv
-- zip_ty_env _ _ env = env
instance Outputable TvSubst where
- ppr (TvSubst ins env)
+ ppr (TvSubst ins tenv)
= brackets $ sep[ ptext (sLit "TvSubst"),
nest 2 (ptext (sLit "In scope:") <+> ppr ins),
- nest 2 (ptext (sLit "Env:") <+> ppr env) ]
+ nest 2 (ptext (sLit "Type env:") <+> ppr tenv) ]
\end{code}
%************************************************************************
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 (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 (PredTy p) = PredTy $! (substPred subst p)
- go (FunTy arg res) = (FunTy $! (go arg)) $! (go res)
- go (AppTy fun arg) = mkAppTy (go fun) $! (go arg)
+ 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 (ForAllTy tv ty) = case substTyVarBndr subst tv of
+ (subst', tv') ->
+ ForAllTy tv' $! (subst_ty subst' ty)
substTyVar :: TvSubst -> TyVar -> Type
-substTyVar subst@(TvSubst _ _) 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 _ 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]
-- (\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}
----------------------------------------------------
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}
--- | Essentially 'funResultTy' on kinds
-kindFunResult :: Kind -> Kind
-kindFunResult k = funResultTy k
-
--- | Essentially 'splitFunTys' on kinds
-splitKindFunTys :: Kind -> ([Kind],Kind)
-splitKindFunTys k = splitFunTys k
-
-splitKindFunTy_maybe :: Kind -> Maybe (Kind,Kind)
-splitKindFunTy_maybe = splitFunTy_maybe
-
--- | Essentially 'splitFunTysN' on kinds
-splitKindFunTysN :: Int -> Kind -> ([Kind],Kind)
-splitKindFunTysN k = splitFunTysN k
-
--- | See "Type#kind_subtyping" for details of the distinction between these 'Kind's
-isUbxTupleKind, isOpenTypeKind, isArgTypeKind, isUnliftedTypeKind :: Kind -> Bool
-isOpenTypeKindCon, isUbxTupleKindCon, isArgTypeKindCon,
- isUnliftedTypeKindCon, isSubArgTypeKindCon :: TyCon -> Bool
-
-isOpenTypeKindCon tc = tyConUnique tc == openTypeKindTyConKey
-
-isOpenTypeKind (TyConApp tc _) = isOpenTypeKindCon tc
-isOpenTypeKind _ = False
-
-isUbxTupleKindCon tc = tyConUnique tc == ubxTupleKindTyConKey
-
-isUbxTupleKind (TyConApp tc _) = isUbxTupleKindCon tc
-isUbxTupleKind _ = False
-
-isArgTypeKindCon tc = tyConUnique tc == argTypeKindTyConKey
-
-isArgTypeKind (TyConApp tc _) = isArgTypeKindCon tc
-isArgTypeKind _ = False
-
-isUnliftedTypeKindCon tc = tyConUnique tc == unliftedTypeKindTyConKey
-
-isUnliftedTypeKind (TyConApp tc _) = isUnliftedTypeKindCon tc
-isUnliftedTypeKind _ = 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 _ = False
-
--- | Is this a super-kind (i.e. a type-of-kinds)?
-isSuperKind :: Type -> Bool
-isSuperKind (TyConApp (skc) []) = isSuperKindTyCon skc
-isSuperKind _ = False
-
--- | Is this a kind (i.e. a type-of-types)?
-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 _ _ = 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 *. See "Type#kind_subtyping" for more
--- information on what that means
-
--- 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 _ = False
-\end{code}
projects / ghc-hetmet.git / blobdiff