[project @ 2003-11-03 16:00:57 by simonpj]

Wibbles to pretty printing of types

diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs
index 6fa5bdc..8815cf5 100644 (file)
--- a/ghc/compiler/typecheck/TcType.lhs
+++ b/ghc/compiler/typecheck/TcType.lhs
@@ -85,6 +85,7 @@ module TcType (
   -- Rexported from Type
   Kind,        -- Stuff to do with kinds is insensitive to pre/post Tc
   unliftedTypeKind, liftedTypeKind, openTypeKind, mkArrowKind, mkArrowKinds, 
+  isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind, isSuperKind,
   superBoxity, liftedBoxity, hasMoreBoxityInfo, defaultKind, superKind,
   isTypeKind, isAnyTypeKind, typeCon,
 
@@ -120,6 +121,8 @@ import Type         (       -- Re-exports
                          tyVarsOfTheta, Kind, Type, PredType(..),
                          ThetaType, unliftedTypeKind, typeCon,
                          liftedTypeKind, openTypeKind, mkArrowKind,
+                         isLiftedTypeKind, isUnliftedTypeKind, 
+                         isOpenTypeKind, isSuperKind,
                          mkArrowKinds, mkForAllTy, mkForAllTys,
                          defaultKind, isTypeKind, isAnyTypeKind,
                          mkFunTy, mkFunTys, zipFunTys, 

diff --git a/ghc/compiler/typecheck/TcUnify.lhs b/ghc/compiler/typecheck/TcUnify.lhs
index 3d70bcb..04a804d 100644 (file)
--- a/ghc/compiler/typecheck/TcUnify.lhs
+++ b/ghc/compiler/typecheck/TcUnify.lhs
@@ -30,7 +30,7 @@ module TcUnify (
 import HsSyn           ( HsExpr(..) )
 import TcHsSyn         ( mkHsLet,
                          ExprCoFn, idCoercion, isIdCoercion, mkCoercion, (<.>), (<$>) )
-import TypeRep         ( Type(..), PredType(..), TyNote(..), typeCon, openKindCon )
+import TypeRep         ( Type(..), PredType(..), TyNote(..), typeCon, openKindCon, isSuperKind )
 
 import TcRnMonad         -- TcType, amongst others
 import TcType          ( TcKind, TcType, TcSigmaType, TcRhoType, TcTyVar, TcTauType,
@@ -43,7 +43,7 @@ import TcType         ( TcKind, TcType, TcSigmaType, TcRhoType, TcTyVar, TcTauType,
                          isSkolemTyVar, isUserTyVar, 
                          tidyOpenType, tidyOpenTypes, tidyOpenTyVar, tidyOpenTyVars,
                          eqKind, openTypeKind, liftedTypeKind, isTypeKind, mkArrowKind,
-                         hasMoreBoxityInfo, allDistinctTyVars, pprType )
+                         hasMoreBoxityInfo, allDistinctTyVars, pprType, pprKind )
 import Inst            ( newDicts, instToId, tcInstCall )
 import TcMType         ( getTcTyVar, putTcTyVar, tcInstType, newKindVar,
                          newTyVarTy, newTyVarTys, newOpenTypeKind,
@@ -992,6 +992,8 @@ unifyMisMatch ty1 ty2
     zonkTcType ty2     `thenM` \ ty2' ->
     let
        (env, [tidy_ty1, tidy_ty2]) = tidyOpenTypes emptyTidyEnv [ty1',ty2']
+       ppr | isSuperKind (typeKind ty1) = pprKind
+           | otherwise                  = pprType
        msg = hang (ptext SLIT("Couldn't match"))
                   4 (sep [quotes (ppr tidy_ty1), 
                           ptext SLIT("against"), 

diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs
index 9de68e2..20dbb00 100644 (file)
--- a/ghc/compiler/types/Type.lhs
+++ b/ghc/compiler/types/Type.lhs
@@ -15,6 +15,7 @@ module Type (
        openKindCon,                                    -- :: KX
        typeCon,                                        -- :: BX -> KX
        liftedTypeKind, unliftedTypeKind, openTypeKind, -- :: KX
+       isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind, isSuperKind,
        mkArrowKind, mkArrowKinds,                      -- :: KX -> KX -> KX
        isTypeKind, isAnyTypeKind,
        funTyCon,

diff --git a/ghc/compiler/types/TypeRep.lhs b/ghc/compiler/types/TypeRep.lhs
index 15eb0f9..a79a4af 100644 (file)
--- a/ghc/compiler/types/TypeRep.lhs
+++ b/ghc/compiler/types/TypeRep.lhs
@@ -17,7 +17,7 @@ module TypeRep (
        openKindCon,                                    -- :: KX
        typeCon,                                        -- :: BX -> KX
        liftedTypeKind, unliftedTypeKind, openTypeKind, -- :: KX
-       isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind,
+       isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind, isSuperKind,
        mkArrowKind, mkArrowKinds,                      -- :: KX -> KX -> KX
 
        funTyCon,
@@ -362,7 +362,7 @@ isOpenTypeKind (TyConApp tc []) = tyConName tc == openKindConName
 isOpenTypeKind other = False
 
 isSuperKind (TyConApp tc []) = tyConName tc == superKindName
-isSuperTypeKind other = False
+isSuperKind other = False
 \end{code}
 
 ------------------------------------------
@@ -522,11 +522,13 @@ ppr_type p ty@(ForAllTy _ _)
     (tvs,  rho) = split1 [] ty
     (ctxt, tau) = split2 [] rho
 
-    split1 tvs (ForAllTy tv ty) = split1 (tv:tvs) ty
-    split1 tvs ty              = (reverse tvs, ty)
+    split1 tvs (ForAllTy tv ty)        = split1 (tv:tvs) ty
+    split1 tvs (NoteTy (FTVNote _) ty) = split1 tvs ty
+    split1 tvs ty                     = (reverse tvs, ty)
  
-    split2 ps (PredTy p `FunTy` ty) = split2 (p:ps) ty
-    split2 ps ty                   = (reverse ps, ty)
+    split2 ps (PredTy p `FunTy` ty)   = split2 (p:ps) ty
+    split2 ps (NoteTy (FTVNote _) ty) = split2 ps ty
+    split2 ps ty                     = (reverse ps, ty)
 
 ppr_tc_app :: Prec -> TyCon -> [Type] -> SDoc
 ppr_tc_app p tc []