projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Fix a long-standing infelicity in the type pretty printer
[ghc-hetmet.git]
/
compiler
/
types
/
Type.lhs
diff --git
a/compiler/types/Type.lhs
b/compiler/types/Type.lhs
index
5908194
..
fd275da
100644
(file)
--- a/
compiler/types/Type.lhs
+++ b/
compiler/types/Type.lhs
@@
-64,7
+64,7
@@
module Type (
Kind, SimpleKind, KindVar,
-- ** Deconstructing Kinds
Kind, SimpleKind, KindVar,
-- ** Deconstructing Kinds
- kindFunResult, splitKindFunTys, splitKindFunTysN,
+ kindFunResult, splitKindFunTys, splitKindFunTysN, splitKindFunTy_maybe,
-- ** Common Kinds and SuperKinds
liftedTypeKind, unliftedTypeKind, openTypeKind,
-- ** Common Kinds and SuperKinds
liftedTypeKind, unliftedTypeKind, openTypeKind,
@@
-98,7
+98,8
@@
module Type (
tidyKind,
-- * Type comparison
tidyKind,
-- * Type comparison
- coreEqType, tcEqType, tcEqTypes, tcCmpType, tcCmpTypes,
+ coreEqType, coreEqType2,
+ tcEqType, tcEqTypes, tcCmpType, tcCmpTypes,
tcEqPred, tcEqPredX, tcCmpPred, tcEqTypeX, tcPartOfType, tcPartOfPred,
-- * Forcing evaluation of types
tcEqPred, tcEqPredX, tcCmpPred, tcEqTypeX, tcPartOfType, tcPartOfPred,
-- * Forcing evaluation of types
@@
-122,7
+123,7
@@
module Type (
emptyTvSubstEnv, emptyTvSubst,
mkTvSubst, mkOpenTvSubst, zipOpenTvSubst, zipTopTvSubst, mkTopTvSubst, notElemTvSubst,
emptyTvSubstEnv, emptyTvSubst,
mkTvSubst, mkOpenTvSubst, zipOpenTvSubst, zipTopTvSubst, mkTopTvSubst, notElemTvSubst,
- getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope,
+ getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope, extendTvInScopeList,
extendTvSubst, extendTvSubstList, isInScope, composeTvSubst, zipTyEnv,
isEmptyTvSubst,
extendTvSubst, extendTvSubstList, isInScope, composeTvSubst, zipTyEnv,
isEmptyTvSubst,
@@
-132,7
+133,7
@@
module Type (
-- * Pretty-printing
pprType, pprParendType, pprTypeApp, pprTyThingCategory, pprTyThing, pprForAll,
-- * Pretty-printing
pprType, pprParendType, pprTypeApp, pprTyThingCategory, pprTyThing, pprForAll,
- pprPred, pprTheta, pprThetaArrow, pprClassPred, pprKind, pprParendKind,
+ pprPred, pprEqPred, pprTheta, pprThetaArrow, pprClassPred, pprKind, pprParendKind,
pprSourceTyCon
) where
pprSourceTyCon
) where
@@
-403,7
+404,7
@@
repSplitAppTy_maybe :: Type -> Maybe (Type,Type)
repSplitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [ty1], ty2)
repSplitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2)
repSplitAppTy_maybe (TyConApp tc tys)
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
+ | 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
= case snocView tys of -- never create unsaturated type family apps
Just (tys', ty') -> Just (TyConApp tc tys', ty')
Nothing -> Nothing
@@
-427,9
+428,9
@@
splitAppTys ty = split ty ty []
split _ (AppTy ty arg) args = split ty ty (arg:args)
split _ (TyConApp tc tc_args) args
= let -- keep type families saturated
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
+ n | isDecomposableTyCon tc = 0
+ | otherwise = tyConArity tc
+ (tc_args1, tc_args2) = splitAt n tc_args
in
(TyConApp tc tc_args1, tc_args2 ++ args)
split _ (FunTy ty1 ty2) args = ASSERT( null args )
in
(TyConApp tc tc_args1, tc_args2 ++ args)
split _ (FunTy ty1 ty2) args = ASSERT( null args )
@@
-446,8
+447,8
@@
splitAppTys ty = split ty ty []
\begin{code}
mkFunTy :: Type -> Type -> Type
-- ^ Creates a function type from the given argument and result type
\begin{code}
mkFunTy :: Type -> Type -> Type
-- ^ Creates a function type from the given argument and result type
-mkFunTy (PredTy (EqPred ty1 ty2)) res = mkForAllTy (mkWildCoVar (PredTy (EqPred ty1 ty2))) res
-mkFunTy arg res = FunTy arg res
+mkFunTy arg@(PredTy (EqPred {})) res = ForAllTy (mkWildCoVar arg) res
+mkFunTy arg res = FunTy arg res
mkFunTys :: [Type] -> Type -> Type
mkFunTys tys ty = foldr mkFunTy ty tys
mkFunTys :: [Type] -> Type -> Type
mkFunTys tys ty = foldr mkFunTy ty tys
@@
-1140,11
+1141,14
@@
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
\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
+coreEqType t1 t2 = coreEqType2 rn_env t1 t2
where
rn_env = mkRnEnv2 (mkInScopeSet (tyVarsOfType t1 `unionVarSet` tyVarsOfType t2))
where
rn_env = mkRnEnv2 (mkInScopeSet (tyVarsOfType t1 `unionVarSet` tyVarsOfType t2))
+coreEqType2 :: RnEnv2 -> Type -> Type -> Bool
+coreEqType2 rn_env t1 t2
+ = eq rn_env t1 t2
+ where
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 (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
@@
-1433,8
+1437,11
@@
notElemTvSubst tv (TvSubst _ env) = not (tv `elemVarEnv` env)
setTvSubstEnv :: TvSubst -> TvSubstEnv -> TvSubst
setTvSubstEnv (TvSubst in_scope _) env = TvSubst in_scope env
setTvSubstEnv :: TvSubst -> TvSubstEnv -> TvSubst
setTvSubstEnv (TvSubst in_scope _) env = TvSubst in_scope env
-extendTvInScope :: TvSubst -> [Var] -> TvSubst
-extendTvInScope (TvSubst in_scope env) vars = TvSubst (extendInScopeSetList in_scope vars) env
+extendTvInScope :: TvSubst -> Var -> TvSubst
+extendTvInScope (TvSubst in_scope env) var = TvSubst (extendInScopeSet in_scope var) env
+
+extendTvInScopeList :: TvSubst -> [Var] -> TvSubst
+extendTvInScopeList (TvSubst in_scope env) vars = TvSubst (extendInScopeSetList in_scope vars) env
extendTvSubst :: TvSubst -> TyVar -> Type -> TvSubst
extendTvSubst (TvSubst in_scope env) tv ty = TvSubst in_scope (extendVarEnv env tv ty)
extendTvSubst :: TvSubst -> TyVar -> Type -> TvSubst
extendTvSubst (TvSubst in_scope env) tv ty = TvSubst in_scope (extendVarEnv env tv ty)
@@
-1720,6
+1727,9
@@
kindFunResult k = funResultTy k
splitKindFunTys :: Kind -> ([Kind],Kind)
splitKindFunTys k = splitFunTys k
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
-- | Essentially 'splitFunTysN' on kinds
splitKindFunTysN :: Int -> Kind -> ([Kind],Kind)
splitKindFunTysN k = splitFunTysN k