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 
-        kindFunResult, splitKindFunTys, splitKindFunTysN,
+        kindFunResult, splitKindFunTys, splitKindFunTysN, splitKindFunTy_maybe,
 
         -- ** Common Kinds and SuperKinds
         liftedTypeKind, unliftedTypeKind, openTypeKind,
@@ -98,7 +98,8 @@ module Type (
        tidyKind,
 
        -- * Type comparison
-       coreEqType, tcEqType, tcEqTypes, tcCmpType, tcCmpTypes, 
+       coreEqType, coreEqType2,
+        tcEqType, tcEqTypes, tcCmpType, tcCmpTypes, 
        tcEqPred, tcEqPredX, tcCmpPred, tcEqTypeX, tcPartOfType, tcPartOfPred,
 
        -- * Forcing evaluation of types
@@ -122,7 +123,7 @@ module Type (
        emptyTvSubstEnv, emptyTvSubst,
        
        mkTvSubst, mkOpenTvSubst, zipOpenTvSubst, zipTopTvSubst, mkTopTvSubst, notElemTvSubst,
-       getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope,
+       getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope, extendTvInScopeList,
        extendTvSubst, extendTvSubstList, isInScope, composeTvSubst, zipTyEnv,
         isEmptyTvSubst,
 
@@ -132,7 +133,7 @@ module Type (
 
        -- * Pretty-printing
        pprType, pprParendType, pprTypeApp, pprTyThingCategory, pprTyThing, pprForAll,
-       pprPred, pprTheta, pprThetaArrow, pprClassPred, pprKind, pprParendKind,
+       pprPred, pprEqPred, pprTheta, pprThetaArrow, pprClassPred, pprKind, pprParendKind,
        
        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) 
-  | 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
@@ -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
-            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 )
@@ -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
-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
@@ -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
-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))
 
+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
@@ -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
 
-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)
@@ -1720,6 +1727,9 @@ kindFunResult k = funResultTy 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