%
+% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1998
%
-\section[Type]{Type - public interface}
+
+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
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
module Type (
-- re-exports from TypeRep
TyThing(..), Type, PredType(..), ThetaType,
funTyCon,
- -- Re-exports from Kind
- module Kind,
+ -- 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,
+
+ isSubArgTypeKind, isSubOpenTypeKind, isSubKind, defaultKind, eqKind,
+ isSubKindCon,
-- Re-exports from TyCon
PrimRep(..),
mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, isTyVarTy,
- mkAppTy, mkAppTys, splitAppTy, splitAppTys, splitAppTy_maybe,
+ mkAppTy, mkAppTys, splitAppTy, splitAppTys,
+ splitAppTy_maybe, repSplitAppTy_maybe,
mkFunTy, mkFunTys, splitFunTy, splitFunTy_maybe,
splitFunTys, splitFunTysN,
mkTyConApp, mkTyConTy,
tyConAppTyCon, tyConAppArgs,
- splitTyConApp_maybe, splitTyConApp,
+ splitTyConApp_maybe, splitTyConApp,
+ splitNewTyConApp_maybe, splitNewTyConApp,
- repType, typePrimRep, coreView, tcView,
+ repType, typePrimRep, coreView, tcView, kindView,
mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys,
applyTy, applyTys, isForAllTy, dropForAlls,
-- Source types
- predTypeRep, mkPredTy, mkPredTys,
+ predTypeRep, mkPredTy, mkPredTys, pprSourceTyCon, mkFamilyTyConApp,
-- Newtypes
- splitRecNewType_maybe,
+ newTyConInstRhs,
-- Lifting and boxity
- isUnLiftedType, isUnboxedTupleType, isAlgType, isPrimitiveType,
- isStrictType, isStrictPred,
+ isUnLiftedType, isUnboxedTupleType, isAlgType, isClosedAlgType,
+ isPrimitiveType, isStrictType, isStrictPred,
-- Free variables
tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,
- typeKind, addFreeTyVars,
+ typeKind,
+
+ -- Type families
+ tyFamInsts,
-- Tidying up for printing
tidyType, tidyTypes,
-- Comparison
coreEqType, tcEqType, tcEqTypes, tcCmpType, tcCmpTypes,
- tcEqPred, tcCmpPred, tcEqTypeX,
+ tcEqPred, tcCmpPred, tcEqTypeX, tcPartOfType, tcPartOfPred,
-- Seq
seqType, seqTypes,
mkTvSubst, mkOpenTvSubst, zipOpenTvSubst, zipTopTvSubst, mkTopTvSubst, notElemTvSubst,
getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope,
extendTvSubst, extendTvSubstList, isInScope, composeTvSubst, zipTyEnv,
+ isEmptyTvSubst,
-- Performing substitution on types
substTy, substTys, substTyWith, substTheta,
- substPred, substTyVar, substTyVarBndr, deShadowTy, lookupTyVar,
+ substPred, substTyVar, substTyVars, substTyVarBndr, deShadowTy, lookupTyVar,
-- Pretty-printing
- pprType, pprParendType, pprTyThingCategory,
- pprPred, pprTheta, pprThetaArrow, pprClassPred
+ pprType, pprParendType, pprTypeApp, pprTyThingCategory, pprTyThing, pprForAll,
+ pprPred, pprTheta, pprThetaArrow, pprClassPred, pprKind, pprParendKind
) where
#include "HsVersions.h"
import TypeRep
-- friends:
-import Kind
-import Var ( Var, TyVar, tyVarKind, tyVarName, setTyVarName, mkTyVar )
+import Var
import VarEnv
import VarSet
-import OccName ( tidyOccName )
-import Name ( NamedThing(..), mkInternalName, tidyNameOcc )
-import Class ( Class, classTyCon )
-import TyCon ( TyCon, isRecursiveTyCon, isPrimTyCon,
- isUnboxedTupleTyCon, isUnLiftedTyCon,
- isFunTyCon, isNewTyCon, newTyConRep, newTyConRhs,
- isAlgTyCon, tyConArity,
- tcExpandTyCon_maybe, coreExpandTyCon_maybe,
- tyConKind, PrimRep(..), tyConPrimRep,
- )
+import Name
+import Class
+import PrelNames
+import TyCon
-- others
-import StaticFlags ( opt_DictsStrict )
-import SrcLoc ( noSrcLoc )
-import Util ( mapAccumL, seqList, lengthIs, snocView, thenCmp, isEqual, all2 )
+import StaticFlags
+import Util
import Outputable
-import UniqSet ( sizeUniqSet ) -- Should come via VarSet
-import Maybe ( isJust )
+import FastString
+
+import Data.List
+import Data.Maybe ( isJust )
\end{code}
\begin{code}
{-# INLINE coreView #-}
coreView :: Type -> Maybe Type
--- Srips off the *top layer only* of a type to give
+-- Strips off the *top layer only* of a type to give
-- its underlying representation type.
-- Returns Nothing if there is nothing to look through.
--
-- 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) = Just (predTypeRep p)
+coreView (PredTy p)
+ | isEqPred p = Nothing
+ | otherwise = 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
tcView (TyConApp tc tys) | Just (tenv, rhs, tys') <- tcExpandTyCon_maybe tc tys
= Just (mkAppTys (substTy (mkTopTvSubst tenv) rhs) tys')
-tcView ty = Nothing
+tcView _ = Nothing
+
+-----------------------------------------------
+{-# INLINE kindView #-}
+kindView :: Kind -> Maybe Kind
+-- C.f. coreView, tcView
+-- For the moment, we don't even handle synonyms in kinds
+kindView _ = Nothing
\end{code}
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}
invariant: use it.
\begin{code}
+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
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)
-splitAppTy_maybe ty | Just ty' <- coreView ty = splitAppTy_maybe ty'
-splitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [ty1], ty2)
-splitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2)
-splitAppTy_maybe (TyConApp tc tys) = case snocView tys of
- Nothing -> Nothing
- Just (tys',ty') -> Just (TyConApp tc tys', ty')
-splitAppTy_maybe other = Nothing
+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
+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
+repSplitAppTy_maybe _other = Nothing
+-------------
splitAppTy :: Type -> (Type, Type)
splitAppTy ty = case splitAppTy_maybe ty of
Just pr -> pr
Nothing -> panic "splitAppTy"
+-------------
splitAppTys :: Type -> (Type, [Type])
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 = (TyConApp tc [], tc_args ++ args)
- split orig_ty (FunTy ty1 ty2) args = ASSERT( null 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
+ in
+ (TyConApp tc tc_args1, tc_args2 ++ 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}
\begin{code}
mkFunTy :: Type -> Type -> Type
+mkFunTy (PredTy (EqPred ty1 ty2)) res = mkForAllTy (mkWildCoVar (PredTy (EqPred ty1 ty2))) res
mkFunTy arg res = FunTy arg res
mkFunTys :: [Type] -> Type -> Type
-mkFunTys tys ty = foldr FunTy ty tys
+mkFunTys tys ty = foldr mkFunTy ty tys
isFunTy :: Type -> Bool
isFunTy ty = isJust (splitFunTy_maybe ty)
splitFunTy_maybe :: Type -> Maybe (Type, 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
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
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
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}
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
+splitTyConApp_maybe _ = 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 _ = Nothing
+
+newTyConInstRhs :: TyCon -> [Type] -> Type
+-- Unwrap one 'layer' of newtype
+-- Use the eta'd version if possible
+newTyConInstRhs tycon tys
+ = ASSERT2( equalLength tvs tys1, ppr tycon $$ ppr tys $$ ppr tvs )
+ mkAppTys (substTyWith tvs tys1 ty) tys2
+ where
+ (tvs, ty) = newTyConEtadRhs tycon
+ (tys1, tys2) = splitAtList tvs tys
\end{code}
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
(b) synonyms
(c) predicates
(d) usage annotations
- (e) all newtypes, including recursive ones
+ (e) all newtypes, including recursive ones, but not newtype families
It's useful in the back end.
\begin{code}
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)
- | isNewTyCon 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( isRecursiveTyCon tc &&
- tys `lengthIs` tyConArity tc )
- repType (new_type_rep tc tys)
-repType ty = ty
-
--- new_type_rep doesn't ask any questions:
--- it just expands newtype, whether recursive or not
-new_type_rep new_tycon tys = ASSERT( tys `lengthIs` tyConArity new_tycon )
- case newTyConRep new_tycon of
- (tvs, rep_ty) -> substTyWith tvs tys rep_ty
+repType ty
+ = 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 ty
+
+ go rec_nts ty@(TyConApp tc tys) -- Expand newtypes
+ | Just _co_con <- newTyConCo_maybe tc -- See Note [Expanding newtypes]
+ = if tc `elem` rec_nts -- in Type.lhs
+ then ty
+ else go rec_nts' nt_rhs
+ where
+ nt_rhs = newTyConInstRhs tc tys
+ rec_nts' | isRecursiveTyCon tc = tc:rec_nts
+ | otherwise = rec_nts
+
+ go _ ty = ty
+
-- ToDo: this could be moved to the code generator, using splitTyConApp instead
-- of inspecting the type directly.
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
-- (we claim) there is no way to constrain f's kind any other
-- way.
-
\end{code}
mkForAllTys tyvars ty = foldr ForAllTy ty tyvars
isForAllTy :: Type -> Bool
-isForAllTy (NoteTy _ ty) = isForAllTy ty
isForAllTy (ForAllTy _ _) = True
-isForAllTy other_ty = False
+isForAllTy _ = False
splitForAllTy_maybe :: Type -> Maybe (TyVar, Type)
splitForAllTy_maybe ty = splitFAT_m ty
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)
dropForAlls :: Type -> Type
dropForAlls ty = snd (splitForAllTys ty)
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
predTypeRep (ClassP clas tys) = mkTyConApp (classTyCon clas) tys
-- Result might be a newtype application, but the consumer will
-- look through that too if necessary
-\end{code}
-
-
-%************************************************************************
-%* *
- NewTypes
-%* *
-%************************************************************************
-
-\begin{code}
-splitRecNewType_maybe :: Type -> Maybe Type
--- Sometimes we want to look through a recursive newtype, and that's what happens here
--- It only strips *one layer* off, so the caller will usually call itself recursively
--- Only applied to types of kind *, hence the newtype is always saturated
-splitRecNewType_maybe ty | Just ty' <- coreView ty = splitRecNewType_maybe ty'
-splitRecNewType_maybe (TyConApp tc tys)
- | isNewTyCon tc
- = ASSERT( tys `lengthIs` tyConArity tc ) -- splitRecNewType_maybe only be applied
- -- to *types* (of kind *)
- ASSERT( isRecursiveTyCon tc ) -- Guaranteed by coreView
- case newTyConRhs tc of
- (tvs, rep_ty) -> ASSERT( length tvs == length tys )
- Just (substTyWith tvs tys rep_ty)
-
-splitRecNewType_maybe other = Nothing
+predTypeRep (EqPred ty1 ty2) = pprPanic "predTypeRep" (ppr (EqPred 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
+
+-- 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 -> SDoc
+pprSourceTyCon tycon
+ | Just (fam_tc, tys) <- tyConFamInst_maybe tycon
+ = ppr $ fam_tc `TyConApp` tys -- can't be FunTyCon
+ | otherwise
+ = ppr tycon
\end{code}
~~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
typeKind :: Type -> Kind
-
-typeKind (TyVarTy tyvar) = tyVarKind tyvar
-typeKind (TyConApp tycon tys) = foldr (\_ k -> kindFunResult k) (tyConKind tycon) tys
-typeKind (NoteTy _ ty) = typeKind ty
-typeKind (PredTy _) = liftedTypeKind -- Predicates are always
- -- represented by lifted types
-typeKind (AppTy fun arg) = kindFunResult (typeKind fun)
-typeKind (FunTy arg res) = liftedTypeKind
-typeKind (ForAllTy tv ty) = typeKind ty
+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
\end{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 (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
tyVarsOfTypes tys = foldr (unionVarSet.tyVarsOfType) emptyVarSet tys
tyVarsOfPred :: PredType -> TyVarSet
-tyVarsOfPred (IParam _ ty) = tyVarsOfType ty
-tyVarsOfPred (ClassP _ tys) = tyVarsOfTypes tys
+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
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Type families}
+%* *
+%************************************************************************
+
+Type family instances occuring in a type after expanding synonyms.
--- 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
+\begin{code}
+tyFamInsts :: Type -> [(TyCon, [Type])]
+tyFamInsts ty
+ | Just exp_ty <- tcView ty = tyFamInsts exp_ty
+tyFamInsts (TyVarTy _) = []
+tyFamInsts (TyConApp tc tys)
+ | isOpenSynTyCon 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}
\begin{code}
tidyTyVarBndr :: TidyEnv -> TyVar -> (TidyEnv, TyVar)
-tidyTyVarBndr (tidy_env, subst) 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'
+ (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
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
+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@(tidy_env, subst) ty
+tidyType env@(_, subst) ty
= go ty
where
go (TyVarTy tv) = case lookupVarEnv subst tv of
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)
where
(envp, tvp) = tidyTyVarBndr env tv
- go_note note@(FTVNote ftvs) = note -- No need to tidy the free tyvars
-
+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}
tidyTopType ty = tidyType emptyTidyEnv ty
\end{code}
-
-%************************************************************************
-%* *
- Tidying Kinds
-%* *
-%************************************************************************
-
-We use a grevious hack for tidying KindVars. A TidyEnv contains
-a (VarEnv Var) substitution, to express the renaming; but
-KindVars are not Vars. The Right Thing ultimately is to make them
-into Vars (and perhaps make Kinds into Types), but I just do a hack
-here: I make up a TyVar just to remember the new OccName for the
-renamed KindVar
-
\begin{code}
+
tidyKind :: TidyEnv -> Kind -> (TidyEnv, Kind)
-tidyKind env@(tidy_env, subst) (KindVar kvar)
- | Just tv <- lookupVarEnv_Directly subst uniq
- = (env, KindVar (setKindVarOcc kvar (getOccName tv)))
- | otherwise
- = ((tidy', subst'), KindVar kvar')
- where
- uniq = kindVarUniq kvar
- (tidy', occ') = tidyOccName tidy_env (kindVarOcc kvar)
- kvar' = setKindVarOcc kvar occ'
- fake_tv = mkTyVar tv_name (panic "tidyKind:fake tv kind")
- tv_name = mkInternalName uniq occ' noSrcLoc
- subst' = extendVarEnv subst fake_tv fake_tv
-
-tidyKind env (FunKind k1 k2)
- = (env2, FunKind k1' k2')
- where
- (env1, k1') = tidyKind env k1
- (env2, k2') = tidyKind env1 k2
+tidyKind env k = tidyOpenType env k
-tidyKind env k = (env, k) -- Atomic kinds
\end{code}
-- construct them
isUnLiftedType ty | Just ty' <- coreView ty = isUnLiftedType ty'
-isUnLiftedType (ForAllTy tv ty) = isUnLiftedType ty
+isUnLiftedType (ForAllTy _ ty) = isUnLiftedType ty
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
isAlgType :: Type -> Bool
-isAlgType ty = case splitTyConApp_maybe ty of
- Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc )
- isAlgTyCon tc
- other -> False
+isAlgType ty
+ = case splitTyConApp_maybe ty of
+ Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc )
+ isAlgTyCon tc
+ _other -> False
+
+-- Should only be applied to *types*; hence the assert
+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)
+ _other -> False
\end{code}
@isStrictType@ computes whether an argument (or let RHS) should
which is below TcType in the hierarchy, so it's convenient to put it here.
\begin{code}
+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
+isStrictPred :: PredType -> Bool
isStrictPred (ClassP clas _) = opt_DictsStrict && not (isNewTyCon (classTyCon clas))
-isStrictPred other = False
+isStrictPred _ = 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
isPrimitiveType ty = case splitTyConApp_maybe ty of
Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc )
isPrimTyCon tc
- other -> False
+ _ -> False
\end{code}
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 (TyConApp tc tys) = tc `seq` seqTypes tys
seqType (ForAllTy tv ty) = tv `seq` seqType ty
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 (ClassP c tys) = c `seq` seqTypes tys
+seqPred (IParam n ty) = n `seq` seqType ty
+seqPred (EqPred ty1 ty2) = seqType ty1 `seq` seqType ty2
\end{code}
-- 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'
+ 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
+ eq _ _ _ = False
\end{code}
tcEqTypeX env t1 t2 = isEqual $ cmpTypeX env t1 t2
\end{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.)
+
+\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
+
+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
+\end{code}
+
Now here comes the real worker
\begin{code}
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 env (PredTy _) t2 = GT
+cmpTypeX _ (FunTy _ _) (TyVarTy _) = GT
+cmpTypeX _ (FunTy _ _) (AppTy _ _) = GT
-cmpTypeX env _ _ = LT
+cmpTypeX _ (TyConApp _ _) (TyVarTy _) = GT
+cmpTypeX _ (TyConApp _ _) (AppTy _ _) = GT
+cmpTypeX _ (TyConApp _ _) (FunTy _ _) = GT
+
+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
cmpPredX env (IParam n1 ty1) (IParam n2 ty2) = (n1 `compare` n2) `thenCmp` cmpTypeX env ty1 ty2
- -- Compare types as well as names for implicit parameters
- -- This comparison is used exclusively (I think) for the
- -- finite map built in TcSimplify
-cmpPredX env (ClassP c1 tys1) (ClassP c2 tys2) = (c1 `compare` c2) `thenCmp` cmpTypesX env tys1 tys2
-cmpPredX env (IParam _ _) (ClassP _ _) = LT
-cmpPredX env (ClassP _ _) (IParam _ _) = GT
+ -- Compare names only for implicit parameters
+ -- This comparison is used exclusively (I believe)
+ -- for the Avails finite map built in TcSimplify
+ -- If the types differ we keep them distinct so that we see
+ -- a distinct pair to run improvement on
+cmpPredX env (ClassP c1 tys1) (ClassP c2 tys2) = (c1 `compare` c2) `thenCmp` (cmpTypesX env tys1 tys2)
+cmpPredX env (EqPred ty1 ty2) (EqPred ty1' ty2') = (cmpTypeX env ty1 ty1') `thenCmp` (cmpTypeX env ty2 ty2')
+
+-- Constructor order: IParam < ClassP < EqPred
+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,
data TvSubst
= TvSubst InScopeSet -- The in-scope type variables
TvSubstEnv -- The substitution itself
- -- See Note [Apply Once]
+ -- See Note [Apply Once]
+ -- and Note [Extending the TvSubstEnv]
{- ----------------------------------------------------------
- Note [Apply Once]
+Note [Apply Once]
+~~~~~~~~~~~~~~~~~
We use TvSubsts to instantiate things, and we might instantiate
forall a b. ty
\with the types
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
+
+
-------------------------------------------------------------- -}
where
subst1 = TvSubst in_scope env1
+emptyTvSubst :: TvSubst
emptyTvSubst = TvSubst emptyInScopeSet emptyVarEnv
isEmptyTvSubst :: TvSubst -> Bool
+ -- See Note [Extending the TvSubstEnv]
isEmptyTvSubst (TvSubst _ env) = isEmptyVarEnv env
mkTvSubst :: InScopeSet -> TvSubstEnv -> TvSubst
-- 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....
+
+
mkOpenTvSubst :: TvSubstEnv -> TvSubst
mkOpenTvSubst env = TvSubst (mkInScopeSet (tyVarsOfTypes (varEnvElts env))) env
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.
zipTopTvSubst :: [TyVar] -> [Type] -> TvSubst
zipTopTvSubst tyvars tys
-#ifdef DEBUG
- | length tyvars /= length tys
- = pprTrace "zipOpenTvSubst" (ppr tyvars $$ ppr tys) emptyTvSubst
+ | 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
+ | debugIsOn && (length tyvars /= length tys)
= pprTrace "mkTopTvSubst" (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
instance Outputable TvSubst where
ppr (TvSubst ins env)
- = sep[ ptext SLIT("<TvSubst"),
- nest 2 (ptext SLIT("In scope:") <+> ppr ins),
- nest 2 (ptext SLIT("Env:") <+> ppr env) ]
+ = brackets $ sep[ ptext (sLit "TvSubst"),
+ nest 2 (ptext (sLit "In scope:") <+> ppr ins),
+ nest 2 (ptext (sLit "Env:") <+> ppr env) ]
\end{code}
%************************************************************************
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
deShadowTy tvs ty
where
in_scope = mkInScopeSet tvs
+subst_ty :: TvSubst -> Type -> Type
+-- subst_ty is the main workhorse for type substitution
+--
-- Note that the in_scope set is poked only if we hit a forall
-- so it may often never be fully computed
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 (NoteTy (FTVNote _) ty2) = go ty2 -- Discard the free tyvar note
-
- 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 tv
- = case lookupTyVar subst tv of
- Nothing -> TyVarTy tv
- Just ty' -> ty' -- See Note [Apply Once]
+substTyVar subst@(TvSubst _ _) tv
+ = case lookupTyVar subst tv of {
+ Nothing -> TyVarTy tv;
+ Just ty -> ty -- See Note [Apply Once]
+ }
+
+substTyVars :: TvSubst -> [TyVar] -> [Type]
+substTyVars subst tvs = map (substTyVar subst) tvs
lookupTyVar :: TvSubst -> TyVar -> Maybe Type
-lookupTyVar (TvSubst in_scope env) tv = lookupVarEnv env tv
+ -- See Note [Extending the TvSubst]
+lookupTyVar (TvSubst _ env) tv = lookupVarEnv env tv
substTyVarBndr :: TvSubst -> TyVar -> (TvSubst, TyVar)
substTyVarBndr subst@(TvSubst in_scope env) old_var
- | old_var == new_var -- No need to clone
- -- But we *must* zap any current substitution for the variable.
- -- For example:
- -- (\x.e) with id_subst = [x |-> e']
- -- Here we must simply zap the substitution for x
- --
- -- The new_id isn't cloned, but it may have a different type
- -- etc, so we must return it, not the old id
- = (TvSubst (in_scope `extendInScopeSet` new_var)
- (delVarEnv env old_var),
- new_var)
-
- | otherwise -- The new binder is in scope so
- -- we'd better rename it away from the in-scope variables
- -- Extending the substitution to do this renaming also
- -- has the (correct) effect of discarding any existing
- -- substitution for that variable
- = (TvSubst (in_scope `extendInScopeSet` new_var)
- (extendVarEnv env old_var (TyVarTy new_var)),
- new_var)
+ = (TvSubst (in_scope `extendInScopeSet` new_var) new_env, new_var)
where
- new_var = uniqAway in_scope old_var
+ is_co_var = isCoVar old_var
+
+ new_env | no_change = delVarEnv env old_var
+ | otherwise = extendVarEnv env old_var (TyVarTy new_var)
+
+ no_change = new_var == old_var && not is_co_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]
+ --
+ -- In that case we don't need to extend the substitution
+ -- to map old to new. But instead we must zap any
+ -- current substitution for the variable. For example:
+ -- (\x.e) with id_subst = [x |-> e']
+ -- Here we must simply zap the substitution for x
+
+ new_var = uniqAway in_scope subst_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}
+
+----------------------------------------------------
+-- Kind Stuff
+
+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}
+type KindVar = TyVar -- invariant: KindVar will always be a
+ -- TcTyVar with details MetaTv TauTv ...
+-- kind var constructors and functions are in TcType
+
+type SimpleKind = Kind
+\end{code}
+
+Kind inference
+~~~~~~~~~~~~~~
+During kind inference, a kind variable unifies only with
+a "simple kind", sk
+ sk ::= * | sk1 -> sk2
+For example
+ data T a = MkT a (T Int#)
+fails. We give T the kind (k -> *), and the kind variable k won't unify
+with # (the kind of Int#).
+
+Type inference
+~~~~~~~~~~~~~~
+When creating a fresh internal type variable, we give it a kind to express
+constraints on it. E.g. in (\x->e) we make up a fresh type variable for x,
+with kind ??.
+
+During unification we only bind an internal type variable to a type
+whose kind is lower in the sub-kind hierarchy than the kind of the tyvar.
+
+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, 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
+
+isSuperKind :: Type -> Bool
+isSuperKind (TyConApp (skc) []) = isSuperKindTyCon skc
+isSuperKind _ = 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 _ _ = 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 _ = False
\end{code}