mkSynTy,
- repType, typePrimRep, coreView,
+ repType, typePrimRep, coreView, deepCoreView,
mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys,
applyTy, applyTys, isForAllTy, dropForAlls,
tidyTyVarBndr, tidyFreeTyVars,
tidyOpenTyVar, tidyOpenTyVars,
tidyTopType, tidyPred,
+ tidyKind,
-- Comparison
- eqType,
+ coreEqType, tcEqType, tcEqTypes, tcCmpType, tcCmpTypes,
+ tcEqPred, tcCmpPred, tcEqTypeX,
-- Seq
seqType, seqTypes,
-- Type substitutions
- TvSubst(..), -- Representation visible to a few friends
- TvSubstEnv, emptyTvSubst,
- mkTvSubst, zipTvSubst, zipTopTvSubst, mkTopTvSubst,
+ TvSubstEnv, emptyTvSubstEnv, -- Representation widely visible
+ TvSubst(..), emptyTvSubst, -- Representation visible to a few friends
+ mkTvSubst, mkOpenTvSubst, zipOpenTvSubst, zipTopTvSubst, mkTopTvSubst, notElemTvSubst,
getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope,
- extendTvSubst, extendTvSubstList, isInScope,
+ extendTvSubst, extendTvSubstList, isInScope, composeTvSubst,
-- Performing substitution on types
- substTy, substTys, substTyWith, substTheta, substTyVar,
- deShadowTy,
+ substTy, substTys, substTyWith, substTheta,
+ substPred, substTyVar, substTyVarBndr, deShadowTy,
-- Pretty-printing
pprType, pprParendType, pprTyThingCategory,
-- friends:
import Kind
-import Var ( Var, TyVar, tyVarKind, tyVarName, setTyVarName )
+import Var ( Var, TyVar, tyVarKind, tyVarName, setTyVarName, mkTyVar )
import VarEnv
import VarSet
)
-- others
-import CmdLineOpts ( opt_DictsStrict )
+import StaticFlags ( opt_DictsStrict )
import SrcLoc ( noSrcLoc )
import Unique ( Uniquable(..) )
-import Util ( mapAccumL, seqList, lengthIs, snocView )
+import Util ( mapAccumL, seqList, lengthIs, snocView, thenCmp, isEqual )
import Outputable
import UniqSet ( sizeUniqSet ) -- Should come via VarSet
import Maybe ( isJust )
coreView (TyConApp tc tys) = expandNewTcApp tc tys
coreView ty = Nothing
+deepCoreView :: Type -> Type
+-- Apply coreView recursively
+deepCoreView ty
+ | Just ty' <- coreView ty = deepCoreView ty'
+deepCoreView (TyVarTy tv) = TyVarTy tv
+deepCoreView (TyConApp tc tys) = TyConApp tc (map deepCoreView tys)
+deepCoreView (AppTy t1 t2) = AppTy (deepCoreView t1) (deepCoreView t2)
+deepCoreView (FunTy t1 t2) = FunTy (deepCoreView t1) (deepCoreView t2)
+deepCoreView (ForAllTy tv ty) = ForAllTy tv (deepCoreView ty)
+ -- No NoteTy, no PredTy
+
expandNewTcApp :: TyCon -> [Type] -> Maybe Type
-- A local helper function (not exported)
-- Expands *the outermoset level of* a newtype application to
-- to *types* (of kind *)
ASSERT( isRecursiveTyCon tc ) -- Guaranteed by coreView
case newTyConRhs tc of
- (tvs, rep_ty) -> Just (substTyWith tvs tys rep_ty)
-
+ (tvs, rep_ty) -> ASSERT( length tvs == length tys )
+ Just (substTyWith tvs tys rep_ty)
+
splitRecNewType_maybe other = Nothing
\end{code}
\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 = (env, k) -- Atomic kinds
+\end{code}
+
%************************************************************************
%* *
%************************************************************************
%* *
-\subsection{Equality on types}
+ Comparison of types
+ (We don't use instances so that we know where it happens)
%* *
%************************************************************************
-Comparison; don't use instances so that we know where it happens.
-Look through newtypes but not usage types.
+Two flavours:
+
+* tcEqType, tcCmpType do *not* look through newtypes, PredTypes
+* coreEqType *does* look through them
Note that eqType can respond 'False' for partial applications of newtypes.
Consider
newtype Parser m a = MkParser (Foogle m a)
-
Does
Monad (Parser m) `eqType` Monad (Foogle m)
-
Well, yes, but eqType won't see that they are the same.
I don't think this is harmful, but it's soemthing to watch out for.
+First, the external interface
+
+\begin{code}
+coreEqType :: Type -> Type -> Bool
+coreEqType t1 t2 = isEqual $ cmpType (deepCoreView t1) (deepCoreView t2)
+
+tcEqType :: Type -> Type -> Bool
+tcEqType t1 t2 = isEqual $ cmpType t1 t2
+
+tcEqTypes :: [Type] -> [Type] -> Bool
+tcEqTypes tys1 tys2 = isEqual $ cmpTypes tys1 tys2
+
+tcCmpType :: Type -> Type -> Ordering
+tcCmpType t1 t2 = cmpType t1 t2
+
+tcCmpTypes :: [Type] -> [Type] -> Ordering
+tcCmpTypes tys1 tys2 = cmpTypes tys1 tys2
+
+tcEqPred :: PredType -> PredType -> Bool
+tcEqPred p1 p2 = isEqual $ cmpPred 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}
+
+Now here comes the real worker
+
\begin{code}
-eqType t1 t2 = eq_ty emptyVarEnv t1 t2
+cmpType :: Type -> Type -> Ordering
+cmpType t1 t2 = cmpTypeX rn_env t1 t2
+ where
+ rn_env = mkRnEnv2 (mkInScopeSet (tyVarsOfType t1 `unionVarSet` tyVarsOfType t2))
+
+cmpTypes :: [Type] -> [Type] -> Ordering
+cmpTypes ts1 ts2 = cmpTypesX rn_env ts1 ts2
+ where
+ rn_env = mkRnEnv2 (mkInScopeSet (tyVarsOfTypes ts1 `unionVarSet` tyVarsOfTypes ts2))
+
+cmpPred :: PredType -> PredType -> Ordering
+cmpPred p1 p2 = cmpPredX rn_env p1 p2
+ where
+ rn_env = mkRnEnv2 (mkInScopeSet (tyVarsOfPred p1 `unionVarSet` tyVarsOfPred p2))
--- Look through Notes, PredTy, newtype applications
-eq_ty env t1 t2 | Just t1' <- coreView t1 = eq_ty env t1' t2
-eq_ty env t1 t2 | Just t2' <- coreView t2 = eq_ty env t1 t2'
+cmpTypeX :: RnEnv2 -> Type -> Type -> Ordering -- Main workhorse
-- NB: we *cannot* short-cut the newtype comparison thus:
--- eq_ty env (NewTcApp tc1 tys1) (NewTcApp tc2 tys2)
--- | (tc1 == tc2) = (eq_tys env tys1 tys2)
+-- eqTypeX env (NewTcApp tc1 tys1) (NewTcApp tc2 tys2)
+-- | (tc1 == tc2) = (eqTypeXs env tys1 tys2)
--
-- Consider:
-- newtype T a = MkT [a]
-- but we can only expand saturated newtypes, so just comparing
-- T with [] won't do.
--- The rest is plain sailing
-eq_ty env (TyVarTy tv1) (TyVarTy tv2) = case lookupVarEnv env tv1 of
- Just tv1a -> tv1a == tv2
- Nothing -> tv1 == tv2
-eq_ty env (ForAllTy tv1 t1) (ForAllTy tv2 t2)
- | tv1 == tv2 = eq_ty (delVarEnv env tv1) t1 t2
- | otherwise = eq_ty (extendVarEnv env tv1 tv2) t1 t2
-eq_ty env (AppTy s1 t1) (AppTy s2 t2) = (eq_ty env s1 s2) && (eq_ty env t1 t2)
-eq_ty env (FunTy s1 t1) (FunTy s2 t2) = (eq_ty env s1 s2) && (eq_ty env t1 t2)
-eq_ty env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 == tc2) && (eq_tys env tys1 tys2)
-eq_ty env t1 t2 = False
-
-eq_tys env [] [] = True
-eq_tys env (t1:tys1) (t2:tys2) = (eq_ty env t1 t2) && (eq_tys env tys1 tys2)
-eq_tys env tys1 tys2 = False
+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
+cmpTypeX env (AppTy s1 t1) (AppTy s2 t2) = cmpTypeX env s1 s2 `thenCmp` cmpTypeX env t1 t2
+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 (NoteTy _ t1) t2 = cmpTypeX env t1 t2
+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 env (PredTy _) t2 = GT
+
+cmpTypeX env _ _ = LT
+
+-------------
+cmpTypesX :: RnEnv2 -> [Type] -> [Type] -> Ordering
+cmpTypesX env [] [] = EQ
+cmpTypesX env (t1:tys1) (t2:tys2) = cmpTypeX env t1 t2 `thenCmp` cmpTypesX env tys1 tys2
+cmpTypesX env [] tys = LT
+cmpTypesX env ty [] = 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
+\end{code}
+
+PredTypes are used as a FM key in TcSimplify,
+so we take the easy path and make them an instance of Ord
+
+\begin{code}
+instance Eq PredType where { (==) = tcEqPred }
+instance Ord PredType where { compare = tcCmpPred }
\end{code}
\begin{code}
data TvSubst
= TvSubst InScopeSet -- The in-scope type variables
- TvSubstEnv -- The substitution itself; guaranteed idempotent
+ TvSubstEnv -- The substitution itself
-- See Note [Apply Once]
{- ----------------------------------------------------------
-- in the middle of matching, and unification (see Types.Unify)
-- So you have to look at the context to know if it's idempotent or
-- apply-once or whatever
+emptyTvSubstEnv :: TvSubstEnv
+emptyTvSubstEnv = emptyVarEnv
+
+composeTvSubst :: InScopeSet -> TvSubstEnv -> TvSubstEnv -> TvSubstEnv
+-- (compose env1 env2)(x) is env1(env2(x)); i.e. apply env2 then env1
+-- It assumes that both are idempotent
+-- Typically, env1 is the refinement to a base substitution env2
+composeTvSubst in_scope env1 env2
+ = env1 `plusVarEnv` mapVarEnv (substTy subst1) env2
+ -- First apply env1 to the range of env2
+ -- Then combine the two, making sure that env1 loses if
+ -- both bind the same variable; that's why env1 is the
+ -- *left* argument to plusVarEnv, because the right arg wins
+ where
+ subst1 = TvSubst in_scope env1
emptyTvSubst = TvSubst emptyInScopeSet emptyVarEnv
isEmptyTvSubst :: TvSubst -> Bool
isEmptyTvSubst (TvSubst _ env) = isEmptyVarEnv env
+mkTvSubst :: InScopeSet -> TvSubstEnv -> TvSubst
+mkTvSubst = TvSubst
+
getTvSubstEnv :: TvSubst -> TvSubstEnv
getTvSubstEnv (TvSubst _ env) = env
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)
+
setTvSubstEnv :: TvSubst -> TvSubstEnv -> TvSubst
setTvSubstEnv (TvSubst in_scope _) env = TvSubst in_scope env
extendTvSubstList (TvSubst in_scope env) tvs tys
= TvSubst in_scope (extendVarEnvList env (tvs `zip` tys))
--- mkTvSubst and zipTvSubst generate the in-scope set from
+-- mkOpenTvSubst and zipOpenTvSubst generate the in-scope set from
-- the types given; but it's just a thunk so with a bit of luck
-- it'll never be evaluated
-mkTvSubst :: TvSubstEnv -> TvSubst
-mkTvSubst env
- = TvSubst (mkInScopeSet (tyVarsOfTypes (varEnvElts env))) env
+mkOpenTvSubst :: TvSubstEnv -> TvSubst
+mkOpenTvSubst env = TvSubst (mkInScopeSet (tyVarsOfTypes (varEnvElts env))) env
-zipTvSubst :: [TyVar] -> [Type] -> TvSubst
-zipTvSubst tyvars tys
+zipOpenTvSubst :: [TyVar] -> [Type] -> TvSubst
+zipOpenTvSubst tyvars tys
+#ifdef DEBUG
+ | 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.
mkTopTvSubst prs = TvSubst emptyInScopeSet (mkVarEnv prs)
zipTopTvSubst :: [TyVar] -> [Type] -> TvSubst
-zipTopTvSubst tyvars tys = TvSubst emptyInScopeSet (zipTyEnv tyvars tys)
+zipTopTvSubst tyvars tys
+#ifdef DEBUG
+ | length tyvars /= length tys
+ = pprTrace "zipOpenTvSubst" (ppr tyvars $$ ppr tys) emptyTvSubst
+ | otherwise
+#endif
+ = TvSubst emptyInScopeSet (zipTyEnv tyvars tys)
zipTyEnv :: [TyVar] -> [Type] -> TvSubstEnv
zipTyEnv tyvars tys
-- and so generated a rep type mentioning t not t2.
--
-- Simplest fix is to nuke the "optimisation"
+zip_ty_env tvs tys env = pprTrace "Var/Type length mismatch: " (ppr tvs $$ ppr tys) env
+-- zip_ty_env _ _ env = env
instance Outputable TvSubst where
ppr (TvSubst ins env)
\begin{code}
substTyWith :: [TyVar] -> [Type] -> Type -> Type
-substTyWith tvs tys = substTy (zipTvSubst tvs tys)
+substTyWith tvs tys = ASSERT( length tvs == length tys )
+ substTy (zipOpenTvSubst tvs tys)
substTy :: TvSubst -> Type -> Type
substTy subst ty | isEmptyTvSubst subst = ty
-- 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@(TvSubst in_scope env) ty
+subst_ty subst ty
= go ty
where
- go ty@(TyVarTy tv) = case (lookupVarEnv env tv) of
- Nothing -> ty
- Just ty' -> ty' -- See Note [Apply Once]
-
+ go (TyVarTy tv) = substTyVar subst tv
go (TyConApp tc tys) = let args = map go tys
in args `seqList` TyConApp tc args
-- 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 substTyVar subst tv of
+ go (ForAllTy tv ty) = case substTyVarBndr subst tv of
(subst', tv') -> ForAllTy tv' $! (subst_ty subst' ty)
-substTyVar :: TvSubst -> TyVar -> (TvSubst, TyVar)
-substTyVar subst@(TvSubst in_scope env) old_var
+substTyVar :: TvSubst -> TyVar -> Type
+substTyVar (TvSubst in_scope env) tv
+ = case (lookupVarEnv env tv) of
+ Nothing -> TyVarTy tv
+ Just ty' -> ty' -- See Note [Apply Once]
+
+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:
--
-- 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),
+ = (TvSubst (in_scope `extendInScopeSet` new_var)
+ (delVarEnv env old_var),
new_var)
| otherwise -- The new binder is in scope so
-- 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)),
+ = (TvSubst (in_scope `extendInScopeSet` new_var)
+ (extendVarEnv env old_var (TyVarTy new_var)),
new_var)
where
new_var = uniqAway in_scope old_var
-- The uniqAway part makes sure the new variable is not already in scope
\end{code}
-
-
projects / ghc-hetmet.git / blobdiff