From: simonpj <unknown>
Date: Mon, 3 Nov 2003 16:01:03 +0000 (+0000)
Subject: [project @ 2003-11-03 16:00:57 by simonpj]
X-Git-Tag: Approx_11550_changesets_converted~283
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=ac41c500b3769f005eeeaf964170a78c79135196;p=ghc-hetmet.git

[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
--- 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
--- 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
--- 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
--- 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 []