%
+% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1998
%
-\section[Type]{Type - public interface}
+Type - public interface
\begin{code}
module Type (
splitTyConApp_maybe, splitTyConApp,
splitNewTyConApp_maybe, splitNewTyConApp,
- repType, typePrimRep, coreView, tcView, kindView,
+ repType, 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,
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,
+ pprType, pprParendType, pprTypeApp, pprTyThingCategory, pprForAll,
pprPred, pprTheta, pprThetaArrow, pprClassPred, pprKind, pprParendKind
) where
import TypeRep
-- friends:
-import Var ( Var, TyVar, tyVarKind, tyVarName,
- setTyVarName, setTyVarKind, mkWildCoVar )
+import Var
import VarEnv
import VarSet
-import OccName ( tidyOccName )
-import Name ( NamedThing(..), tidyNameOcc )
-import Class ( Class, classTyCon )
-import PrelNames( openTypeKindTyConKey, unliftedTypeKindTyConKey,
- ubxTupleKindTyConKey, argTypeKindTyConKey )
-import TyCon ( TyCon, isRecursiveTyCon, isPrimTyCon,
- isUnboxedTupleTyCon, isUnLiftedTyCon,
- isFunTyCon, isNewTyCon, newTyConRep, newTyConRhs,
- isAlgTyCon, tyConArity, isSuperKindTyCon,
- tcExpandTyCon_maybe, coreExpandTyCon_maybe,
- tyConKind, PrimRep(..), tyConPrimRep, tyConUnique,
- isCoercionTyCon_maybe, isCoercionTyCon
- )
+import Name
+import Class
+import PrelNames
+import TyCon
-- others
-import StaticFlags ( opt_DictsStrict )
-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 UniqSet
+
+import Data.List
+import Data.Maybe ( isJust )
\end{code}
newTyConInstRhs :: TyCon -> [Type] -> Type
newTyConInstRhs tycon tys =
let (tvs, ty) = newTyConRhs tycon in substTyWith tvs tys ty
-
\end{code}
(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 ty | Just ty' <- coreView ty = repType ty'
repType (ForAllTy _ ty) = repType ty
repType (TyConApp tc tys)
- | isNewTyCon tc = -- Recursive newtypes are opaque to coreView
+ | 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 *
repType (new_type_rep tc tys)
repType ty = ty
+-- repType' aims to be a more thorough version of repType
+-- For now it simply looks through the TyConApp args too
+repType' ty -- | pprTrace "repType'" (ppr ty $$ ppr (go1 ty)) False = undefined
+ | otherwise = go1 ty
+ where
+ go1 = go . repType
+ go (TyConApp tc tys) = mkTyConApp tc (map repType' tys)
+ 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 )
-- 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))
+
+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 (fam_tc, tys) <- tyConFamInst_maybe tycon
+ = ppr $ fam_tc `TyConApp` tys -- can't be FunTyCon
+ | otherwise
+ = ppr tycon
\end{code}
-- 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
+ | isClosedNewTyCon tc
= ASSERT( tys `lengthIs` tyConArity tc ) -- splitRecNewType_maybe only be applied
-- to *types* (of kind *)
ASSERT( isRecursiveTyCon tc ) -- Guaranteed by coreView
Just (substTyWith tvs tys rep_ty)
splitRecNewType_maybe other = Nothing
-
-
-
\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
-------------
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 env (IParam {}) _ = LT
+cmpPredX env (ClassP {}) (IParam {}) = GT
+cmpPredX env (ClassP {}) (EqPred {}) = LT
+cmpPredX env (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
+
+
-------------------------------------------------------------- -}
emptyTvSubst = TvSubst emptyInScopeSet emptyVarEnv
isEmptyTvSubst :: TvSubst -> Bool
+ -- See Note [Extending the TvSubstEnv]
isEmptyTvSubst (TvSubst _ env) = isEmptyVarEnv env
mkTvSubst :: InScopeSet -> TvSubstEnv -> TvSubst
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)
substTyVar :: TvSubst -> TyVar -> Type
substTyVar subst@(TvSubst in_scope env) tv
= case lookupTyVar subst tv of {
- Nothing -> TyVarTy tv;
+ 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
+ -- See Note [Extending the TvSubst]
lookupTyVar (TvSubst in_scope env) tv = lookupVarEnv env tv
substTyVarBndr :: TvSubst -> TyVar -> (TvSubst, TyVar)
substTyVarBndr subst@(TvSubst in_scope env) old_var
= (TvSubst (in_scope `extendInScopeSet` new_var) new_env, new_var)
where
+ 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
-- 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 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
- kind = tyVarKind old_var
- is_co_var = isCoercionKind kind
\end{code}
----------------------------------------------------
isSubKind :: Kind -> Kind -> Bool
-- (k1 `isSubKind` k2) checks that k1 <: k2
-isSubKind (TyConApp kc1 []) (TyConApp kc2 []) = kc1 `isSubKindCon` kc1
+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'
| isSubArgTypeKind k = liftedTypeKind
| otherwise = k
-isCoercionKind :: Kind -> Bool
--- All coercions are of form (ty1 :=: ty2)
--- This function is here rather than in Coercion,
--- because it's used by substTy
-isCoercionKind k | Just k' <- kindView k = isCoercionKind k'
-isCoercionKind (PredTy (EqPred {})) = True
-isCoercionKind other = False
-
isEqPred :: PredType -> Bool
isEqPred (EqPred _ _) = True
isEqPred other = False