Type - public interface
\begin{code}
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
module Type (
-- re-exports from TypeRep
TyThing(..), Type, PredType(..), ThetaType,
applyTy, applyTys, isForAllTy, dropForAlls,
-- Source types
- predTypeRep, mkPredTy, mkPredTys,
- tyConOrigHead, pprSourceTyCon,
+ predTypeRep, mkPredTy, mkPredTys, pprSourceTyCon, mkFamilyTyConApp,
-- Newtypes
- splitRecNewType_maybe, newTyConInstRhs,
+ newTyConInstRhs,
-- Lifting and boxity
isUnLiftedType, isUnboxedTupleType, isAlgType, isPrimitiveType,
tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,
typeKind, addFreeTyVars,
+ -- Type families
+ tyFamInsts,
+
-- Tidying up for printing
tidyType, tidyTypes,
tidyOpenType, tidyOpenTypes,
-- 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, substTyVars, substTyVarBndr, deShadowTy, lookupTyVar,
-- Pretty-printing
- pprType, pprParendType, pprTypeApp, pprTyThingCategory, pprForAll,
+ pprType, pprParendType, pprTypeApp, pprTyThingCategory, pprTyThing, pprForAll,
pprPred, pprTheta, pprThetaArrow, pprClassPred, pprKind, pprParendKind
) where
import Outputable
import UniqSet
+import Data.List
import Data.Maybe ( isJust )
\end{code}
splitNewTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res])
splitNewTyConApp_maybe other = Nothing
--- get instantiated newtype rhs, the arguments had better saturate
--- the constructor
newTyConInstRhs :: TyCon -> [Type] -> Type
-newTyConInstRhs tycon tys =
- let (tvs, ty) = newTyConRhs tycon in substTyWith tvs tys ty
+-- 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}
repType ty | Just ty' <- coreView ty = repType ty'
repType (ForAllTy _ ty) = repType ty
repType (TyConApp tc tys)
- | isClosedNewTyCon 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)
+ | isNewTyCon tc
+ , (tvs, rep_ty) <- newTyConRep tc
+ = -- Recursive newtypes are opaque to coreView
+ -- but we must expand them here. Sure to
+ -- be saturated because repType is only applied
+ -- to types of kind *
+ ASSERT( tys `lengthIs` tyConArity tc )
+ repType (substTyWith tvs tys rep_ty)
+
repType ty = ty
-- repType' aims to be a more thorough version of repType
go 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
-
-- ToDo: this could be moved to the code generator, using splitTyConApp instead
-- of inspecting the type directly.
typePrimRep :: Type -> PrimRep
-- 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}
-- look through that too if necessary
predTypeRep (EqPred ty1 ty2) = pprPanic "predTypeRep" (ppr (EqPred ty1 ty2))
--- The original head is the tycon and its variables for a vanilla tycon and it
--- is the family tycon and its type indexes for a family instance.
-tyConOrigHead :: TyCon -> (TyCon, [Type])
-tyConOrigHead tycon = case tyConFamInst_maybe tycon of
- Nothing -> (tycon, mkTyVarTys (tyConTyVars tycon))
- Just famInst -> famInst
+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
- | Just (repTyCon, tys) <- tyConFamInst_maybe tycon
- = ppr $ repTyCon `TyConApp` tys -- can't be FunTyCon
+ | Just (fam_tc, tys) <- tyConFamInst_maybe tycon
+ = ppr $ fam_tc `TyConApp` tys -- can't be FunTyCon
| otherwise
= ppr tycon
\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)
- | isClosedNewTyCon 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
-
-
-
-\end{code}
-
-
-%************************************************************************
-%* *
\subsection{Kinds and free variables}
%* *
%************************************************************************
%************************************************************************
%* *
+\subsection{Type families}
+%* *
+%************************************************************************
+
+Type family instances occuring in a type after expanding synonyms.
+
+\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}
+
+
+%************************************************************************
+%* *
\subsection{TidyType}
%* *
%************************************************************************
\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
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
+tcPartOfType t1 t2
+ | Just t2' <- tcView t2 = tcPartOfType t1 t2'
+tcPartOfType t1 (ForAllTy _ t2) = tcPartOfType t1 t2
+tcPartOfType t1 (AppTy s2 t2) = tcPartOfType t1 s2 || tcPartOfType t1 t2
+tcPartOfType t1 (FunTy s2 t2) = tcPartOfType t1 s2 || tcPartOfType t1 t2
+tcPartOfType t1 (PredTy p2) = tcPartOfPred t1 p2
+tcPartOfType t1 (TyConApp _ ts) = any (tcPartOfType t1) ts
+tcPartOfType t1 (NoteTy _ t2) = tcPartOfType t1 t2
+
+tcPartOfPred :: Type -> PredType -> Bool
+tcPartOfPred t1 (IParam _ t2) = tcPartOfType t1 t2
+tcPartOfPred t1 (ClassP _ ts) = any (tcPartOfType t1) ts
+tcPartOfPred t1 (EqPred s2 t2) = tcPartOfType t1 s2 || tcPartOfType t1 t2
+\end{code}
+
Now here comes the real worker
\begin{code}
zipTopTvSubst tyvars tys
#ifdef DEBUG
| length tyvars /= length tys
- = pprTrace "zipOpenTvSubst" (ppr tyvars $$ ppr tys) emptyTvSubst
+ = pprTrace "zipTopTvSubst" (ppr tyvars $$ ppr tys) emptyTvSubst
| otherwise
#endif
= TvSubst emptyInScopeSet (zipTyEnv tyvars tys)
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
projects / ghc-hetmet.git / blobdiff